diff --git a/CMakeLists.txt b/CMakeLists.txt index bb27522c81..239cba6359 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -125,11 +125,22 @@ 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_time_utils.F90 + diag_manager/fms_diag_object.F90 + diag_manager/fms_diag_yaml.F90 + diag_manager/fms_diag_file_object.F90 + diag_manager/fms_diag_field_object.F90 + diag_manager/fms_diag_axis_object.F90 + diag_manager/fms_diag_dlinked_list.F90 + diag_manager/fms_diag_object_container.F90 + diag_manager/fms_diag_output_buffer.F90 + diag_manager/fms_diag_input_buffer.F90 diag_manager/fms_diag_time_reduction.F90 diag_manager/fms_diag_outfield.F90 diag_manager/fms_diag_elem_weight_procs.F90 diag_manager/fms_diag_fieldbuff_update.F90 diag_manager/fms_diag_bbox.F90 + diag_manager/fms_diag_reduction_methods.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/Makefile.am b/Makefile.am index 22fb68f97d..cd8837ffe1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -45,6 +45,7 @@ SUBDIRS = \ mosaic2 \ fms \ parser \ + string_utils \ affinity \ mosaic \ time_manager \ diff --git a/configure.ac b/configure.ac index 223733b9f9..a33b8810cf 100644 --- a/configure.ac +++ b/configure.ac @@ -191,9 +191,9 @@ if test $with_yaml = yes; then #If the test pass, define use_yaml macro AC_DEFINE([use_yaml], [1], [This is required to use yaml parser]) - AM_CONDITIONAL([SKIP_PARSER_TESTS], false ) + AM_CONDITIONAL([USING_YAML], true) else - AM_CONDITIONAL([SKIP_PARSER_TESTS], true ) + AM_CONDITIONAL([USING_YAML], false) fi # Require netCDF diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 13ea77d8b7..025066c9d5 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -38,33 +38,68 @@ libdiag_manager_la_SOURCES = \ diag_output.F90 \ diag_table.F90 \ diag_util.F90 \ + fms_diag_time_utils.F90 \ + fms_diag_file_object.F90 \ + fms_diag_field_object.F90 \ + fms_diag_yaml.F90 \ + fms_diag_object.F90 \ + fms_diag_axis_object.F90 \ + fms_diag_object_container.F90 \ + fms_diag_dlinked_list.F90 \ + fms_diag_output_buffer.F90 \ + fms_diag_input_buffer.F90 \ fms_diag_time_reduction.F90 \ fms_diag_outfield.F90 \ fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ + fms_diag_reduction_methods.F90 \ include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.fh \ + include/fms_diag_reduction_methods.inc \ + include/fms_diag_reduction_methods_r4.fh \ + include/fms_diag_reduction_methods_r8.fh # Some mods are dependant on other mods in this dir. diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) -diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_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) fms_diag_bbox_mod.$(FC_MODEXT) + diag_grid_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) +fms_diag_time_utils_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) -fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) -fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_time_utils_mod.$(FC_MODEXT) \ + fms_diag_output_buffer_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_input_buffer_mod.$(FC_MODEXT) +fms_diag_input_buffer_mod.$(FC_MODEXT): fms_diag_axis_object_mod.$(FC_MODEXT) +fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ + fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_input_buffer_mod.$(FC_MODEXT) +fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ + fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) +fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) +fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) +fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) + fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_bbox_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_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_fieldbuff_update_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_file_object_mod.$(FC_MODEXT) \ + fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ + fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) +fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) +fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \ + diag_data_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ @@ -73,17 +108,30 @@ MODFILES = \ diag_grid_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ + fms_diag_time_utils_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ + fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_file_object_mod.$(FC_MODEXT) \ + fms_diag_field_object_mod.$(FC_MODEXT) \ + fms_diag_object_mod.$(FC_MODEXT) \ + fms_diag_axis_object_mod.$(FC_MODEXT) \ + fms_diag_dlinked_list_mod.$(FC_MODEXT) \ + fms_diag_object_container_mod.$(FC_MODEXT) \ + fms_diag_output_buffer_mod.$(FC_MODEXT) \ + fms_diag_input_buffer_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) \ fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_mod.$(FC_MODEXT) \ include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.fh \ + include/fms_diag_reduction_methods_r4.fh \ + include/fms_diag_reduction_methods_r8.fh - nodist_include_HEADERS = $(MODFILES) +nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) include $(top_srcdir)/mkmods.mk diff --git a/diag_manager/README.md b/diag_manager/README.md new file mode 100644 index 0000000000..53abdab392 --- /dev/null +++ b/diag_manager/README.md @@ -0,0 +1,342 @@ +## Diag Table Yaml Format: + +The purpose of this document is to explain the diag_table yaml format. + +## Contents +- [1. Converting from legacy ascii diag_table format](README.md#1-converting-from-legacy-ascii-diag_table-format) +- [2. Diag table yaml sections](README.md#2-diag-table-yaml-sections) +- [2.1 Global Section](README.md#21-global-section) +- [2.2 File Section](README.md#22-file-section) +- [2.2.1 Flexible output timings](README.md#221-flexible-output-timings) +- [2.2.2 Coupled Model Diag Files](README.md#222-coupled-model-diag-files) +- [2.3 Variable Section](README.md#23-variable-section) +- [2.4 Variable Metadata Section](README.md#24-variable-metadata-section) +- [2.5 Global Meta Data Section](README.md#25-global-meta-data-section) +- [2.6 Sub_region Section](README.md#26-sub_region-section) +- [3. More examples](README.md#3-more-examples) + +### 1. Converting from legacy ascii diag_table format + +To convert the legacy ascii diad_table format to this yaml format, the python script [**diag_table_to_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/diag_table_to_yaml.py#L23-L26) can be used. To confirm that your diag_table.yaml was created correctly, the python script [**is_valid_diag_table_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/is_valid_diag_table_yaml.py#L24-L27) can be used. + +### 2. Diag table yaml sections +The diag_table.yaml is organized by file. Each file has the required and optional key/value pairs for the file, an optional subsection defining any additional global metadata to add to the file, an optional subsection defining a subregion of the grid to output the data for and a required subsection for all of the variables in the file. Each variable has the required and optional key/value pairs for the variable and an optional subsection defining any additional variable attributes to add to the file. The hierarchical structure looks like this: + +```yaml +title: +base_date: +diag_files: +- file1 + - #key/value pairs for file1 + varlist: + - var1 + - #key/value pairs for var1 + attributes: + - #atributes for var1 + global_metadata: + - #global attributes for file1 + subregion: + - #subregion for file1 +``` + +### 2.1 Global Section +The diag_yaml requires “title” and the “baseDate”. +- The **title** is a string that labels the diag yaml. The equivalent in the legacy diag_table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it. +- The **basedate** is an array of 6 integers indicating the base_date in the format [year month day hour minute second]. + +**Example:** + +In the YAML format: +```yaml +title: ESM4_piControl +base_date: 2022 5 26 12 3 1 +``` + +In the legacy ascii format: +``` +ESM4_piControl +2022 5 26 12 3 1 +``` + +### 2.2 File Section +The files are listed under the diagFiles section as a dashed array. + +Below are the **required** keys needed to define each file. +- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will be handled by FMS. +- **freq** defines the frequency and the units that data will be written + - The acceptable values for freq are: + - =-1: output at the end of the run only + - =0: output every timestep + - \>0 units: output frequency and units (with a space between the frequency number and units e.g 24 hours) + - Values of -1 or 0 do not require units. + - The acceptable values for units are seconds, minutes, hours, days, months, years. +- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years. +- **unlimdim** is a string that defines the name of the unlimited dimension in the output netcdf file, usually “time”. +- **varlist** is a subsection that list all of the variable in the file + +**Example:** The following creates a file with data written every 6 hours. + +In the YAML format: +```yaml +diag_files: +- file_name: atmos_6hours + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - varinfo +``` + +In the legacy ascii format: +``` +"atmos_6hours", 6, "hours", 1, "hours", "time" +``` + +**NOTE:** The fourth column (file_format) has been deprecated. Netcdf files will always be written. + +Below are some *optional* keys that may be added. +- **write_file** is a logical that indicates if you want the file to be created (default is true). This is a new feature that is not supported by the legacy ascii data_table. +- **new_file_freq** is a string that defines the frequency and the frequency units (with a space between the frequency number and units) for closing the existing file +- **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq” +- **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle + +**Example:** The following will create a new file every 6 hours starting at Jan 1 2020. Variable data will be written to the file every 6 hours. + +In the YAML format: +```yaml +- file_name: ocn%4yr%2mo%2dy%2hr + freq: 6 hours + freq_units: hours + unlimdim: time + new_file_freq: 6 hours + start_time: 2020 1 1 0 0 0 +``` + +In the legacy ascii format: +``` +"ocn%4yr%2mo%2dy%2hr", 6, "hours", 1, "hours", "time", 6, "hours", "1901 1 1 0 0 0" +``` + +Because this is using the default `filename_time` (middle), this example will create the files: +``` +ocn_2020_01_01_03.nc for time_bnds [0,6] +ocn_2020_01_01_09.nc for time_bnds [6,12] +ocn_2020_01_01_15.nc for time_bnds [12,18] +ocn_2020_01_01_21.nc for time_bnds [18,24] +``` + +**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above. + +- **file_duration** is a string that defines 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. +- **global_meta** is a subsection that lists any additional global metadata to add to the file. This is a new feature that is not supported by the legacy ascii data_table. +- **sub_region** is a subsection that defines the four corners of a subregional section to capture. + +### 2.2.1 Flexible output timings + +In order to provide more flexibility in output timings, the diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `new_file_freq`, and `file_duration` keys to accept a comma seperated list. + +For example, +``` yaml +- file_name: flexible_timing%4yr%2mo%2dy%2hr + freq: 1 hours, 1 hours, 1 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours, 3 hours, 1 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours, 3 hours, 9 hours + filename_time: begin + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +``` +This will create a file every 6 hours for 12 hours +``` +flexible_timing_0002_01_01_00.nc - using hourly averaged data from hour 0 to hour 6 +flexible_timing_0002_01_01_06.nc - using hourly averaged data from hour 6 to hour 12 +``` + +Then it will create a file every 3 hours for 3 hours +``` +flexible_timing_0002_01_01_12.nc - using hourly averaged data from hour 12 to hour 15 +``` + +Then it will create a file every 1 hour for 9 hours. +``` +flexible_timing_0002_01_01_15.nc - using data from hour 15 to hour 16 +flexible_timing_0002_01_01_16.nc - using data from hour 16 to hour 17 +flexible_timing_0002_01_01_17.nc - using data from hour 17 to hour 18 +flexible_timing_0002_01_01_18.nc - using data from hour 18 to hour 19 +flexible_timing_0002_01_01_19.nc - using data from hour 19 to hour 20 +flexible_timing_0002_01_01_20.nc - using data from hour 20 to hour 21 +flexible_timing_0002_01_01_21.nc - using data from hour 21 to hour 22 +flexible_timing_0002_01_01_22.nc - using data from hour 22 to hour 23 +flexible_timing_0002_01_01_23.nc - using data from hour 23 to hour 24 + +``` + +### 2.2.2 Coupled Model Diag Files +In the *legacy ascii diag_table*, when running a coupled model (ATM + OCN) in a seperate PE list: + - The ATM PEs ignored the files in the diag_table that contain "OCEAN" in the filename + - The OCN PEs ignored the files in the diag_table that did not contain "OCEAN" in the filename + +In the *yaml diag_table*: + - The ATM PEs will ignore the files in the diag_table.yaml that contain the key/value pair `is_ocean: true` + - The OCN PEs will ignore the files in the diag_table.yaml that do not contain the key/value pair `is_ocean: true` + +### 2.3 Variable Section +The variables in each file are listed under the varlist section as a dashed array. + +- **var_name:** is a string that defines the variable name as it is defined in the register_diag_field call in the model +- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum. +- **module:** is a string that defines the module where the variable is registered in the model code +- **kind:** is a string that defines the type of variable as it will be written out in the file. Acceptable values are r4, r8, i4, and i8 + +**Example:** + +In the YAML format: +```yaml + varlist: + - module: moist + var_name: precip + reduction: average + kind: r4 +``` + +In the legacy ascii format: +``` +"moist", "precip", "precip", "atmos_8xdaily", "all", .true., "none", 2 +``` +**NOTE:** The fifth column (time_sampling) has been deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name. + +which corresponds to the following model code +```F90 +id_precip = register_diag_field ( 'moist', 'precip', axes, Time) +``` +where: +- `moist` corresonds to the module key in the diag_table.yaml +- `precip` corresponds to the var_name key in the diag_table.yaml +- `axes` are the ids of the axes the variable is a function of +- `Time` is the model time + +Below are some *optional* keys that may be added. +- **write_var:** is a logical that is set to false if the user doesn’t want the variable to be written to the file (default: true). +- **out_name:** is a string that defines the name of the variable that will be written to the file (default same as var_name) +- **long_name:** is a string defining the long_name attribute of the variable. It overwrites the long_name in the variable's register_diag_field call +- **attributes:** is a subsection with any additional metadata to add to the variable in the netcdf file. This is a new feature that is not supported by the legacy ascii data_table. +- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits. + +### 2.4 Variable Metadata Section +Any aditional variable attributes can be added for each variable can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value. + +**Example:** + +```yaml + attributes: + - attribute_name: attribute_value + attribute_name: attribute_value +``` + +Although this was not supported by the legacy ascii data_table, with the legacy diag_manager, a call to `diag_field_add_attribute` could have been used to do the same thing. + +```F90 +call diag_field_add_attribute(diag_field_id, attribute_name, attribute_value) +``` + +### 2.5 Global Meta Data Section +Any aditional global attributes can be added for each file can be listed under the global_meta section as a dashed array. The key is the attribute name and the value is the attribute value. + +```yaml + global_meta: + - attribute_name: attribute_value + attribute_name: attribute_value +``` + +### 2.6 Sub_region Section +The sub region can be listed under the sub_region section as a dashed array. The legacy ascii diag_table only allows regions to be defined using the latitude and longitude, and it only allowed rectangular sub regions. With the yaml diag_table, you can use indices to defined the sub_region and you can define **any** four corner shape. Each file can only have 1 sub_region defined. These are keys that can be used: +- **grid_type:** is a **required** string defining the method used to define the fourth sub_region corners. The acceptable values are "latlon" if using latitude/longitude or "indices" if using the indices of the corners. +- **corner1:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the first corner of a sub_grid. +- **corner2:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the second corner of a sub_grid. +- **corner3:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the third corner of a sub_grid. +- **corner4:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the fourth corner of a sub_grid. +- **tile:** is an integer defining the tile number the sub_grid is on. It is **required** only if using (grid_type="indices"). + +**Exampe:** + +```yaml + sub_region: + - grid_type: latlon + corner1: -80, 0 + corner2: -80, 75 + corner3: -60, 0 + corner4: -60, 75 +``` + +### 3. More examples +Bellow is a complete example of diag_table.yaml: +```yaml +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 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours + varlist: + - module: test_diag_manager_mod + var_name: sst + reduction: average + kind: r4 + global_meta: + - is_a_file: true +- file_name: normal + freq: 24 days + time_units: hours + unlimdim: records + varlist: + - module: test_diag_manager_mod + var_name: sst + reduction: average + kind: r4 + write_var: true + attributes: + - do_sst: .true. + sub_region: + - grid_type: latlon + corner1: -80, 0 + corner2: -80, 75 + corner3: -60, 0 + corner4: -60, 75 +- file_name: normal2 + freq: -1 days + time_units: hours + unlimdim: records + write_file: true + varlist: + - module: test_diag_manager_mod + var_name: sstt + reduction: average + kind: r4 + long_name: S S T + - module: test_diag_manager_mod + var_name: sstt2 + reduction: average + kind: r4 + write_var: false + sub_region: + - grid_type: index + tile: 1 + corner1: 10, 15 + corner2: 20, 15 + corner3: 10, 25 + corner4: 20, 25 +- file_name: normal3 + freq: -1 days + time_units: hours + unlimdim: records + write_file: false +``` diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 606ebd76f2..85bd119bf6 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -39,7 +39,8 @@ MODULE diag_axis_mod & fms_error_handler, FATAL, NOTE USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,& & max_num_axis_sets, max_axis_attributes, debug_diag_manager,& - & first_send_data_call, diag_atttype + & first_send_data_call, diag_atttype, use_modern_diag + use fms_diag_object_mod, only:fms_diag_object USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR IMPLICIT NONE @@ -52,7 +53,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 @@ -134,6 +135,14 @@ INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, d CALL write_version_number("DIAG_AXIS_MOD", version) ENDIF + if (use_modern_diag) then + !TODO Passing in the axis_length because of a gnu issue where inside fms_diag_axis_init, the size of DATA + !was 2 which was causing the axis_data to not be written correctly... + diag_axis_init = fms_diag_object%fms_diag_axis_init(name, array_data, units, cart_name, size(array_data(:)), & + & long_name=long_name, direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, & + & DomainU=DomainU, aux=aux, req=req, tile_count=tile_count, domain_position=domain_position) + return + endif IF ( PRESENT(tile_count)) THEN tile = tile_count ELSE @@ -576,12 +585,16 @@ SUBROUTINE get_diag_axis_data(id, axis_data) END SUBROUTINE get_diag_axis_data !> @brief Return the short name of the axis. - SUBROUTINE get_diag_axis_name(id, name) + SUBROUTINE get_diag_axis_name(id, axis_name) INTEGER , INTENT(in) :: id !< Axis ID - CHARACTER(len=*), INTENT(out) :: name !< Axis short name + CHARACTER(len=*), INTENT(out) :: axis_name !< Axis short name - CALL valid_id_check(id, 'get_diag_axis_name') - name = Axes(id)%name + if (use_modern_diag) then + axis_name = fms_diag_object%fms_get_axis_name_from_id(id) + else + CALL valid_id_check(id, 'get_diag_axis_name') + axis_name = Axes(id)%name + endif END SUBROUTINE get_diag_axis_name !> @brief Return the name of the axis' domain @@ -599,14 +612,18 @@ INTEGER FUNCTION get_axis_length(id) INTEGER, INTENT(in) :: id !< Axis ID INTEGER :: length - CALL valid_id_check(id, 'get_axis_length') - IF ( Axes(id)%Domain .NE. null_domain1d ) THEN - CALL mpp_get_compute_domain(Axes(id)%Domain,size=length) - !---one extra point is needed for some case. ( like symmetry domain ) - get_axis_length = length + Axes(id)%shift - ELSE - get_axis_length = Axes(id)%length - END IF + if (use_modern_diag) then + get_axis_length = fms_diag_object%fms_get_axis_length(id) + else + CALL valid_id_check(id, 'get_axis_length') + IF ( Axes(id)%Domain .NE. null_domain1d ) THEN + CALL mpp_get_compute_domain(Axes(id)%Domain,size=length) + !---one extra point is needed for some case. ( like symmetry domain ) + get_axis_length = length + Axes(id)%shift + ELSE + get_axis_length = Axes(id)%length + END IF + endif END FUNCTION get_axis_length !> @brief Return the auxiliary name for the axis. @@ -688,6 +705,12 @@ TYPE(domain2d) FUNCTION get_domain2d(ids) ! input argument has incorrect size. CALL error_mesg('diag_axis_mod::get_domain2d', 'input argument has incorrect size', FATAL) END IF + + if (use_modern_diag) then + get_domain2d = fms_diag_object%fms_get_domain2d(ids) + return + endif + get_domain2d = null_domain2d flag = 0 DO i = 1, SIZE(ids(:)) @@ -1040,7 +1063,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name REAL, INTENT(in) :: att_value - CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /)) + if (use_modern_diag) then + call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /)) + else + CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /)) + endif END SUBROUTINE diag_axis_add_attribute_scalar_r SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value) @@ -1048,7 +1075,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name INTEGER, INTENT(in) :: att_value - CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /)) + if (use_modern_diag) then + call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /)) + else + CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /)) + endif END SUBROUTINE diag_axis_add_attribute_scalar_i SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value) @@ -1056,7 +1087,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name CHARACTER(len=*), INTENT(in) :: att_value - CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_CHAR, cval=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /)) + else + CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_CHAR, cval=att_value) + endif END SUBROUTINE diag_axis_add_attribute_scalar_c SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value) @@ -1064,15 +1099,22 @@ SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name REAL, DIMENSION(:), INTENT(in) :: att_value - CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value) + else + CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value) + endif END SUBROUTINE diag_axis_add_attribute_r1d SUBROUTINE diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value) INTEGER, INTENT(in) :: diag_axis_id CHARACTER(len=*), INTENT(in) :: att_name INTEGER, DIMENSION(:), INTENT(in) :: att_value - - CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_INT, ival=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value) + else + CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_INT, ival=att_value) + endif END SUBROUTINE diag_axis_add_attribute_i1d !> @brief Allocates memory in out_file for the attributes. Will FATAL if err_msg is not included diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index e5d7942946..91eb66780c 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -48,10 +48,12 @@ MODULE diag_data_mod use platform_mod - USE time_manager_mod, ONLY: time_type + USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type + USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG - USE fms_mod, ONLY: WARNING, write_version_number + USE fms_mod, ONLY: write_version_number USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + use mpp_mod, ONLY: mpp_error, FATAL, WARNING, mpp_pe, mpp_root_pe, stdlog ! NF90_FILL_REAL has value of 9.9692099683868690e+36. USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL @@ -62,6 +64,29 @@ MODULE diag_data_mod PUBLIC ! 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 + !> 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 @@ -73,13 +98,35 @@ MODULE diag_data_mod INTEGER, PARAMETER :: DIAG_SECONDS = 1, DIAG_MINUTES = 2, DIAG_HOURS = 3 INTEGER, PARAMETER :: DIAG_DAYS = 4, DIAG_MONTHS = 5, DIAG_YEARS = 6 INTEGER, PARAMETER :: MAX_SUBAXES = 10 + INTEGER, PARAMETER :: NO_DOMAIN = 1 !< Use the FmsNetcdfFile_t fileobj + INTEGER, PARAMETER :: TWO_D_DOMAIN = 2 !< Use the FmsNetcdfDomainFile_t fileobj + INTEGER, PARAMETER :: UG_DOMAIN = 3 !< Use the FmsNetcdfUnstructuredDomainFile_t fileobj + INTEGER, PARAMETER :: SUB_REGIONAL = 4 !< This is a file with a sub_region use the FmsNetcdfFile_t fileobj + INTEGER, PARAMETER :: DIRECTION_UP = 1 !< The axis points up if positive + INTEGER, PARAMETER :: DIRECTION_DOWN = -1 !< The axis points down if positive INTEGER, PARAMETER :: GLO_REG_VAL = -999 !< Value used in the region specification of the diag_table !! to indicate to use the full axis instead of a sub-axis INTEGER, PARAMETER :: GLO_REG_VAL_ALT = -1 !< Alternate value used in the region specification of the !! diag_table to indicate to use the full axis instead of a sub-axis - REAL, PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value + REAL(r8_kind), PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value INTEGER, PARAMETER :: DIAG_FIELD_NOT_FOUND = -1 !< Return value for a diag_field that isn't found in the diag_table - + INTEGER, PARAMETER :: latlon_gridtype = 1 + INTEGER, PARAMETER :: index_gridtype = 2 + INTEGER, PARAMETER :: null_gridtype = DIAG_NULL + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera + INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms + INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max + INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min + INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum + INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal + INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power + CHARACTER(len=7) :: avg_name = 'average' !< Name of the average fields + CHARACTER(len=8) :: no_units = "NO UNITS"!< String indicating that the variable has no units + INTEGER, PARAMETER :: begin_time = 1 !< Use the begining of the time average bounds + INTEGER, PARAMETER :: middle_time = 2 !< Use the middle of the time average bounds + INTEGER, PARAMETER :: end_time = 3 !< Use the end of the time average bounds + INTEGER, PARAMETER :: MAX_STR_LEN = 255 !< Max length for a string !> @} !> @brief Contains the coordinates of the local domain to output. @@ -280,6 +327,15 @@ MODULE diag_data_mod CHARACTER(len=128) :: tile_name='N/A' END TYPE diag_global_att_type + !> @brief Type to hold the attributes of the field/axis/file + !> @ingroup diag_data_mod + type fmsDiagAttribute_type + class(*), allocatable :: att_value(:) !< Value of the attribute + character(len=:), allocatable :: att_name !< Name of the attribute + contains + procedure :: add => fms_add_attribute + procedure :: write_metadata + end type fmsDiagAttribute_type ! Include variable "version" to be written to log file. #include @@ -330,24 +386,38 @@ MODULE diag_data_mod !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. - + LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code + LOGICAL :: use_clock_average = .false. !< .TRUE. if the averaging of variable is done based on the clock + !! For example, if doing daily averages and your start the simulation in + !! day1_hour3, it will do the average between day1_hour3 to day2_hour 0 + !! the default behavior will do the average between day1 hour3 to day2 hour3 ! REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the !! netCDF module, otherwise will be 9.9692099683868690e+36. ! from file /usr/local/include/netcdf.inc + !! @note `pack_size` and `pack_size_str` are set in diag_manager_init depending on how FMS was compiled + !! if FMS was compiled with default reals as 64bit, it will be set to 1 and "double", + !! if FMS was compiled with default reals as 32bit, it will set to 2 and "float" + !! The time variables will written in the precision defined by `pack_size_str` + !! This is to reproduce previous diag manager behavior. + !TODO This may not be mixed precision friendly INTEGER :: pack_size = 1 !< 1 for double and 2 for float + CHARACTER(len=6) :: pack_size_str="double" !< Pack size as a string to be used in fms2_io register call + !! set to "double" or "float" ! - REAL :: EMPTY = 0.0 - REAL :: MAX_VALUE, MIN_VALUE + REAL(r8_kind) :: EMPTY = 0.0 + REAL(r8_kind) :: MAX_VALUE, MIN_VALUE ! TYPE(time_type) :: diag_init_time !< Time diag_manager_init called. If init_time not included in !! diag_manager_init call, then same as base_time - TYPE(time_type) :: base_time - INTEGER :: base_year, base_month, base_day, base_hour, base_minute, base_second + TYPE(time_type), private :: base_time !< The base_time read from diag_table + logical, private :: base_time_set !< Flag indicating that the base_time is set + !! This is to prevent users from calling set_base_time multiple times + INTEGER, private :: base_year, base_month, base_day, base_hour, base_minute, base_second CHARACTER(len = 256):: global_descriptor ! @@ -381,10 +451,197 @@ SUBROUTINE diag_data_init() ! Write version number out to log file call write_version_number("DIAG_DATA_MOD", version) + module_is_initialized = .true. + base_time_set = .false. + END SUBROUTINE diag_data_init + !> @brief Set the module variable base_time + subroutine set_base_time(base_time_int) + integer :: base_time_int(6) !< base_time as an array [year month day hour min sec] + + CHARACTER(len=9) :: amonth !< Month name + INTEGER :: stdlog_unit !< Fortran file unit number for the stdlog file. + + if (.not. module_is_initialized) call mpp_error(FATAL, "set_base_time: diag_data is not initialized") + if (base_time_set) call mpp_error(FATAL, "set_base_time: the base_time is already set!") + + base_year = base_time_int(1) + base_month = base_time_int(2) + base_day = base_time_int(3) + base_hour = base_time_int(4) + base_minute = base_time_int(5) + base_second = base_time_int(6) + + ! Set up the time type for base time + IF ( get_calendar_type() /= NO_CALENDAR ) THEN + IF ( base_year==0 .OR. base_month==0 .OR. base_day==0 ) THEN + call mpp_error(FATAL, 'diag_data_mod::set_base_time'//& + & 'The base_year/month/day can not equal zero') + END IF + base_time = set_date(base_year, base_month, base_day, base_hour, base_minute, base_second) + amonth = month_name(base_month) + ELSE + ! No calendar - ignore year and month + base_time = set_time(NINT(base_hour*SECONDS_PER_HOUR)+NINT(base_minute*SECONDS_PER_MINUTE)+base_second, & + & base_day) + base_year = 0 + base_month = 0 + amonth = 'day' + END IF + + ! get the stdlog unit number + stdlog_unit = stdlog() + IF ( mpp_pe() == mpp_root_pe() ) THEN + WRITE (stdlog_unit,'("base date used = ",I4,1X,A,2I3,2(":",I2.2)," gmt")') base_year, TRIM(amonth), base_day, & + & base_hour, base_minute, base_second + END IF + base_time_set = .true. + + end subroutine set_base_time + + !> @brief gets the module variable base_time + !> @return the base_time + function get_base_time() & + result(res) + TYPE(time_type) :: res + res = base_time + end function get_base_time + + !> @brief gets the module variable base_year + !> @return the base_year + function get_base_year() & + result(res) + integer :: res + res = base_year + end function get_base_year + + !> @brief gets the module variable base_month + !> @return the base_month + function get_base_month() & + result(res) + integer :: res + res = base_month + end function get_base_month + + !> @brief gets the module variable base_day + !> @return the base_day + function get_base_day() & + result(res) + integer :: res + res = base_day + end function get_base_day + + !> @brief gets the module variable base_hour + !> @return the base_hour + function get_base_hour() & + result(res) + integer :: res + res = base_hour + end function get_base_hour + + !> @brief gets the module variable base_minute + !> @return the base_minute + function get_base_minute() & + result(res) + integer :: res + res = base_minute + end function get_base_minute + + !> @brief gets the module variable base_second + !> @return the base_second + function get_base_second() & + result(res) + integer :: res + res = base_second + end function get_base_second + + !> @brief Adds an attribute to the attribute type + subroutine fms_add_attribute(this, att_name, att_value) + class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + integer :: natt !< the size of att_value + + natt = size(att_value) + this%att_name = att_name + select type (att_value) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%att_value(natt)) + this%att_value = att_value + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%att_value(natt)) + this%att_value = att_value + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%att_value(natt)) + this%att_value = att_value + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: this%att_value(natt)) + this%att_value = att_value + type is (character(len=*)) + allocate(character(len=len(att_value)) :: this%att_value(natt)) + this%att_value = att_value + end select + end subroutine fms_add_attribute + + !> @brief gets the type of a variable + !> @return the type of the variable (r4,r8,i4,i8,string) + function get_var_type(var) & + result(var_type) + class(*), intent(in) :: var !< Variable to get the type for + integer :: var_type !< The variable's type + + select type(var) + type is (real(r4_kind)) + var_type = r4 + type is (real(r8_kind)) + var_type = r8 + type is (integer(i4_kind)) + var_type = i4 + type is (integer(i8_kind)) + var_type = i8 + type is (character(len=*)) + var_type = string + class default + call mpp_error(FATAL, "get_var_type:: The variable does not have a supported type. "& + &"The supported types are r4, r8, i4, i8 and string.") + end select + end function get_var_type + + !> @brief Writes out the attributes from an fmsDiagAttribute_type + subroutine write_metadata(this, fileobj, var_name, cell_methods) + class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type + class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to + character(len=*), intent(in) :: var_name !< The name of the variable to write to + character(len=*), optional, intent(inout) :: cell_methods !< The cell methods attribute + + select type (att_value =>this%att_value) + type is (character(len=*)) + !< If the attribute is cell methods append to the current cell_methods attribute value + !! This will be writen once all of the cell_methods attributes are gathered ... + if (present(cell_methods)) then + if (trim(this%att_name) .eq. "cell_methods") then + cell_methods = trim(cell_methods)//" "//trim(att_value(1)) + return + endif + endif + + call register_variable_attribute(fileobj, var_name, this%att_name, trim(att_value(1)), & + str_len=len_trim(att_value(1))) + type is (real(kind=r8_kind)) + call register_variable_attribute(fileobj, var_name, this%att_name, real(att_value, kind=r8_kind)) + type is (real(kind=r4_kind)) + call register_variable_attribute(fileobj, var_name, this%att_name, real(att_value, kind=r4_kind)) + type is (integer(kind=i4_kind)) + call register_variable_attribute(fileobj, var_name, this%att_name, int(att_value, kind=i4_kind)) + type is (integer(kind=i8_kind)) + call register_variable_attribute(fileobj, var_name, this%att_name, int(att_value, kind=i8_kind)) + end select + + end subroutine write_metadata END MODULE diag_data_mod !> @} ! close documentation grouping diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 9a72598915..605f9ed875 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -201,6 +201,9 @@ MODULE diag_manager_mod ! The values are defined as GLO_REG_VAL (-999) and GLO_REG_VAL_ALT ! (-1) in diag_data_mod. ! + ! + ! Set to true, diag_manager uses mpp_io. Default is fms2_io. + ! ! USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& @@ -208,7 +211,7 @@ MODULE diag_manager_mod & get_ticks_per_second USE mpp_mod, ONLY: mpp_get_current_pelist, mpp_pe, mpp_npes, mpp_root_pe, mpp_sum - USE mpp_mod, ONLY: input_nml_file + USE mpp_mod, ONLY: input_nml_file, mpp_error USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,& & fms_error_handler, check_nml_error, lowercase @@ -223,19 +226,22 @@ MODULE diag_manager_mod USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,& & END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,& & max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,& - & MAX_VALUE, MIN_VALUE, base_time, base_year, base_month, base_day,& - & base_hour, base_minute, base_second, global_descriptor, coord_type, files, input_fields,& + & MAX_VALUE, MIN_VALUE, get_base_time, get_base_year, get_base_month, get_base_day,& + & get_base_hour, get_base_minute, get_base_second, global_descriptor, coord_type, files, input_fields,& & output_fields, Time_zero, append_pelist_name, mix_snapshot_average_fields,& & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,& & 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_refactored_send + & use_mpp_io, use_refactored_send, & + & use_modern_diag, use_clock_average, diag_null, pack_size_str 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 USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end + use fms_diag_object_mod, only:fms_diag_object + USE constants_mod, ONLY: SECONDS_PER_DAY USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & @@ -341,6 +347,7 @@ MODULE diag_manager_mod MODULE PROCEDURE send_data_1d MODULE PROCEDURE send_data_2d MODULE PROCEDURE send_data_3d + MODULE PROCEDURE send_data_4d END INTERFACE !> @brief Register a diagnostic field for a given module @@ -398,18 +405,26 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL) END IF END IF - - IF ( PRESENT(init_time) ) THEN - register_diag_field_scalar = register_diag_field_array(module_name, field_name,& - & (/null_axis_id/), init_time,long_name, units, missing_value, range, & - & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,& - & area=area, volume=volume, realm=realm) - ELSE - register_diag_field_scalar = register_static_field(module_name, field_name,& - & (/null_axis_id/),long_name, units, missing_value, range,& - & standard_name=standard_name, do_not_log=do_not_log, realm=realm) - END IF - END FUNCTION register_diag_field_scalar + if (use_modern_diag) then + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name,& + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif + register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( & + & module_name, field_name, init_time, long_name=long_name, units=units, & + & missing_value=missing_value, var_range=range, standard_name=standard_name, & + & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm) + else + register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, & + & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, & + & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm) + endif + end function register_diag_field_scalar !> @brief Registers an array field !> @return field index for subsequent call to send_data. @@ -438,6 +453,142 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + if (use_modern_diag) then + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,& + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif + register_diag_field_array = fms_diag_object%fms_register_diag_field_array( & + & module_name, field_name, axes, init_time, long_name=long_name, & + & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & + & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + else + register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, & + & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & + & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + 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,& + & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& + & tile_count, area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute + CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has + !! a mask variant + LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated + !! with this field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated + !! with this field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + + ! Fatal error if the module has not been initialized. + IF ( .NOT.module_is_initialized ) THEN + ! diag_manager has NOT been initialized + CALL error_mesg ('diag_manager_mod::register_static_field', 'diag_manager has NOT been initialized', FATAL) + END IF + + if (use_modern_diag) then + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,& + & units, missing_value, range, dynamic=.false.) + else + call log_diag_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic=.false.) + endif + endif + register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & + & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & + & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& + & tile_count=tile_count, area=area, volume=volume, realm=realm) + else + register_static_field = register_static_field_old(module_name, field_name, axes, & + & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & + & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& + & tile_count=tile_count, area=area, volume=volume, realm=realm) + endif +END FUNCTION register_static_field + + !> @brief Registers a scalar field + !! @return field index for subsequent call to send_data. + INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_time, & + & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,& + & area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + + IF ( PRESENT(err_msg) ) err_msg = '' + + IF ( PRESENT(init_time) ) THEN + register_diag_field_scalar_old = register_diag_field_array(module_name, field_name,& + & (/null_axis_id/), init_time,long_name, units, missing_value, range, & + & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,& + & area=area, volume=volume, realm=realm) + ELSE + register_diag_field_scalar_old = register_static_field(module_name, field_name,& + & (/null_axis_id/),long_name, units, missing_value, range,& + & standard_name=standard_name, do_not_log=do_not_log, realm=realm) + END IF + END FUNCTION register_diag_field_scalar_old + + !> @brief Registers an array field + !> @return field index for subsequent call to send_data. + INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, & + & long_name, units, missing_value, range, mask_variant, standard_name, verbose,& + & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name, field_name + INTEGER, INTENT(in) :: axes(:) + TYPE(time_type), INTENT(in) :: init_time + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name + CLASS(*), OPTIONAL, INTENT(in) :: missing_value + CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + INTEGER :: field, j, ind, file_num, freq INTEGER :: output_units INTEGER :: stdout_unit @@ -471,7 +622,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END IF ! Call register static, then set static back to false - register_diag_field_array = register_static_field(module_name, field_name, axes,& + register_diag_field_array_old = register_static_field(module_name, field_name, axes,& & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,& & DYNAMIC=.TRUE., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm) @@ -486,7 +637,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t &' registered AFTER first send_data call, TOO LATE', WARNING) END IF - IF ( register_diag_field_array < 0 ) THEN + IF ( register_diag_field_array_old < 0 ) THEN ! ! module/output_field / NOT found in diag_table ! @@ -497,8 +648,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t & WARNING) END IF ELSE - input_fields(register_diag_field_array)%static = .FALSE. - field = register_diag_field_array + input_fields(register_diag_field_array_old)%static = .FALSE. + field = register_diag_field_array_old ! Verify that area and volume do not point to the same variable @@ -508,7 +659,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t err_msg = 'diag_manager_mod::register_diag_field: module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' AREA and VOLUME CANNOT be the same variable.& & Contact the developers.' - register_diag_field_array = -1 + register_diag_field_array_old = -1 RETURN ELSE CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '& @@ -526,7 +677,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t err_msg = 'diag_manager_mod::register_diag_field: module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' AREA measures field NOT found in diag_table.& & Contact the model liaison.' - register_diag_field_array = -1 + register_diag_field_array_old = -1 RETURN ELSE CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '& @@ -542,7 +693,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t err_msg = 'diag_manager_mod::register_diag_field: module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' VOLUME measures field NOT found in diag_table.& & Contact the model liaison.' - register_diag_field_array = -1 + register_diag_field_array_old = -1 RETURN ELSE CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '& @@ -610,11 +761,11 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END DO END IF - END FUNCTION register_diag_field_array + END FUNCTION register_diag_field_array_old !> @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,& + INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_name, units,& & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& & tile_count, area, volume, realm) CHARACTER(len=*), INTENT(in) :: module_name, field_name @@ -642,12 +793,12 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, LOGICAL :: mask_variant1, dynamic1, allow_log CHARACTER(len=128) :: msg INTEGER :: domain_type, i - character(len=256) :: axes_list, axis_name + character(len=256) :: axis_name ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN ! diag_manager has NOT been initialized - CALL error_mesg ('diag_manager_mod::register_static_field', 'diag_manager has NOT been initialized', FATAL) + CALL error_mesg ('diag_manager_mod::register_static_field_old', 'diag_manager has NOT been initialized', FATAL) END IF ! Check if OPTIONAL parameters were passed in. @@ -702,15 +853,15 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! only writes log if do_diag_field_log is true in the namelist (default false) ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - CALL log_diag_field_info (module_name, field_name, axes, & + CALL log_diag_field_info (module_name, field_name, axes, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF - register_static_field = find_input_field(module_name, field_name, 1) - field = register_static_field + register_static_field_old = find_input_field(module_name, field_name, 1) + field = register_static_field_old ! Negative index returned if this field was not found in the diag_table. - IF ( register_static_field < 0 ) RETURN + IF ( register_static_field_old < 0 ) RETURN ! Check that the axes are compatible with each other domain_type = axis_compatible_check(axes,field_name) @@ -727,7 +878,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF CALL init_input_field(module_name, field_name, tile) - register_static_field = find_input_field(module_name, field_name, tile) + register_static_field_old = find_input_field(module_name, field_name, tile) DO j = 1, input_fields(field)%num_output_fields out_num = input_fields(field)%output_fields(j) file_num = output_fields(out_num)%output_file @@ -740,7 +891,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile) END IF END DO - field = register_static_field + field = register_static_field_old END IF ! Store information for this input field into input field table @@ -761,7 +912,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! Verify that area and volume do not point to the same variable IF ( PRESENT(volume).AND.PRESENT(area) ) THEN IF ( area.EQ.volume ) THEN - CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '& + CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' AREA and VOLUME CANNOT be the same variable.& & Contact the developers.',& & FATAL) @@ -771,7 +922,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! Check for the existence of the area/volume field(s) IF ( PRESENT(area) ) THEN IF ( area < 0 ) THEN - CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '& + CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' AREA measures field NOT found in diag_table.& & Contact the model liaison.n',& & FATAL) @@ -779,7 +930,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF IF ( PRESENT(volume) ) THEN IF ( volume < 0 ) THEN - CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '& + CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '& &//TRIM(module_name)//'/'// TRIM(field_name)//' VOLUME measures field NOT found in diag_table& & Contact the model liaison.',& & FATAL) @@ -899,7 +1050,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, file_num = output_fields(out_num)%output_file if (domain_type .eq. DIAG_AXIS_2DDOMAIN) then if (files(file_num)%use_domainUG) then - call error_mesg("diag_manager_mod::register_static_field", & + call error_mesg("diag_manager_mod::register_static_field_old", & "Diagnostics living on a structured grid" & //" and an unstructured grid cannot exist" & //" in the same file (" & @@ -910,7 +1061,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, endif elseif (domain_type .eq. DIAG_AXIS_UGDOMAIN) then if (files(file_num)%use_domain2D) then - call error_mesg("diag_manager_mod::register_static_field", & + call error_mesg("diag_manager_mod::register_static_field_old", & "Diagnostics living on a structured grid" & //" and an unstructured grid cannot exist" & //" in the same file (" & @@ -1010,7 +1161,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! minimum on static fields. Setting the time operation to 'NONE' ! for this field. ! - CALL error_mesg ('diag_manager_mod::register_static_field',& + CALL error_mesg ('diag_manager_mod::register_static_field_old',& & 'module/field '//TRIM(msg)//' is STATIC. Cannot perform time operations& & average, maximum, or minimum on static fields. Setting the time operation& & to "NONE" for this field.', WARNING) @@ -1057,7 +1208,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! Set the cell_measures attribute in the out file CALL init_field_cell_measures(output_fields(out_num), area=area, volume=volume, err_msg=msg) IF ( LEN_TRIM(msg).GT.0 ) THEN - CALL error_mesg ('diag_manager_mod::register_static_field',& + CALL error_mesg ('diag_manager_mod::register_static_field_old',& & TRIM(msg)//' for module/field '//TRIM(module_name)//'/'//TRIM(field_name),& & FATAL) END IF @@ -1090,7 +1241,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF END DO END IF - END FUNCTION register_static_field + END FUNCTION register_static_field_old !> @brief Return the diagnostic field ID of a given variable. !! @return get_diag_field_id will return the ID returned during the register_diag_field call. @@ -1100,9 +1251,16 @@ INTEGER FUNCTION get_diag_field_id(module_name, field_name) CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable CHARACTER(len=*), INTENT(in) :: field_name !< Variable name + integer :: i !< For do loops + + get_diag_field_id = DIAG_FIELD_NOT_FOUND + if (use_modern_diag) then + get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name) + else ! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not ! included in the diag_table get_diag_field_id = find_input_field(module_name, field_name, tile_count=1) + endif END FUNCTION get_diag_field_id !> @brief Finds the corresponding related output field and file for a given input field @@ -1297,7 +1455,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) TYPE(time_type), INTENT(in), OPTIONAL :: time CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL :: field_out(1, 1, 1) !< Local copy of field + CLASS(*), allocatable :: field_out(:, :, :) !< Local copy of field ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1308,9 +1466,23 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) ! First copy the data to a three d array with last element 1 SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) - field_out(1, 1, 1) = field + allocate(real(r4_kind) :: field_out(1,1,1)) + select type(field_out) + type is (real(r4_kind)) + field_out(1, 1, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_0d', & + & 'Error allocating field out as real(r4_kind)', FATAL) + end select TYPE IS (real(kind=r8_kind)) - field_out(1, 1, 1) = real(field) + allocate(real(r8_kind) :: field_out(1,1,1)) + select type(field_out) + type is (real(r8_kind)) + field_out(1, 1, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_0d', & + & 'Error allocating field out as real(r8_kind)', FATAL) + end select CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_0d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1330,7 +1502,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field + CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return @@ -1340,11 +1512,26 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie END IF ! First copy the data to a three d array with last element 1 + ! type checking done in diag_send_data SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) - field_out(:, 1, 1) = field + allocate(real(r4_kind) :: field_out(SIZE(field),1,1)) + select type(field_out) + type is (real(r4_kind)) + field_out(:, 1, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_1d', & + & 'Error allocating field out as real(r4_kind)', FATAL) + end select TYPE IS (real(kind=r8_kind)) - field_out(:, 1, 1) = real(field) + allocate(real(r8_kind) :: field_out(SIZE(field),1,1)) + select type(field_out) + type is (real(r8_kind)) + field_out(:, 1, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_1d', & + & 'Error allocating field out as real(r8_kind)', FATAL) + end select CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_1d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1399,7 +1586,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field + CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return @@ -1411,9 +1598,23 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & ! First copy the data to a three d array with last element 1 SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) - field_out(:, :, 1) = field + allocate(real(r4_kind) :: field_out(SIZE(field,1),SIZE(field,2),1)) + select type(field_out) + type is (real(r4_kind)) + field_out(:, :, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_2d', & + & 'Error allocating field out as real(r4_kind)', FATAL) + end select TYPE IS (real(kind=r8_kind)) - field_out(:, :, 1) = real(field) + allocate(real(r8_kind) :: field_out(SIZE(field,1),SIZE(field,2),1)) + select type(field_out) + type is (real(r8_kind)) + field_out(:, :, 1) = field + class default + call error_mesg('diag_manager_mod::send_data_2d', & + & 'Error allocating field out as real(r8_kind)', FATAL) + end select CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_2d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1474,16 +1675,18 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) endif END FUNCTION send_data_3d + !> @return true if send is successful +!TODO documentation, seperate the old and new LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), DIMENSION(:,:,:), INTENT(in),TARGET,CONTIGUOUS :: field CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL :: weight1 @@ -1518,7 +1721,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, CHARACTER(len=128) :: error_string, error_string1 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - + class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped array + logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped array + class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped array REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! Set up array lengths for remapping + + + endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) field_out = field @@ -1565,9 +1775,25 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, field_out = real(field) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + & 'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//& + & 'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', FATAL) END SELECT - + ! Split old and modern2023 here + modern_if: iF (use_modern_diag) then + field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id) + field_remap = copy_3d_to_4d(field, trim(field_name)//"'s data") + if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask, trim(field_name)//"'s mask") + if (present(mask)) then + allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1)) + mask_remap(:,:,:,1) = mask + endif + diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, & + time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & + err_msg) + deallocate (field_remap) + if (allocated(mask_remap)) deallocate(mask_remap) + if (allocated(rmask_remap)) deallocate(rmask_remap) + elSE ! modern_if ! oor_mask is only used for checking out of range values. ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) IF ( status .NE. 0 ) THEN @@ -3252,8 +3478,60 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, DEALLOCATE(field_out) DEALLOCATE(oor_mask) + endIF modern_if END FUNCTION diag_send_data + !> @brief Updates the output buffer for a field based on the data for current time step + !! @return true if send is successful + LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id !< The field id returned from the register call + CLASS(*), INTENT(in) :: field(:,:,:,:) !< The field data for the current time step + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight to multiply the data by when averaging + TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current model time + INTEGER, INTENT(in), OPTIONAL :: is_in !< Starting i index of the data + INTEGER, INTENT(in), OPTIONAL :: js_in !< Starting j index of the data + INTEGER, INTENT(in), OPTIONAL :: ks_in !< Starting k index of the data + INTEGER, INTENT(in), OPTIONAL :: ie_in !< Ending i index of the data + INTEGER, INTENT(in), OPTIONAL :: je_in !< Ending j index of the data + INTEGER, INTENT(in), OPTIONAL :: ke_in !< Ending k index of the data + LOGICAL, INTENT(in), OPTIONAL :: mask(:,:,:,:) !< Logical mask indicating the points to not average + CLASS(*), INTENT(in), OPTIONAL :: rmask(:,:,:,:) !< Real mask indicating the points to not averafe + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< If some errors occurs, send_data will return the + !! error message instead of crashing + + class(*), allocatable :: rmask_local(:,:,:,:) !< Real version of the mask variable + logical, allocatable :: mask_local(:,:,:,:) !< Local version of the mask variable + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_4d = .FALSE. + RETURN + ENDIF + + if (.not. use_modern_diag) & + call mpp_error(FATAL, "Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.") + + !< The error checking is done in accept_data + if (present(mask)) mask_local = mask + if (present(rmask)) rmask_local = rmask + + send_data_4d = fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, & + time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & + err_msg) + + if (present(err_msg)) then + if (err_msg .ne. "") then + call mpp_error(NOTE, trim(err_msg)) + send_data_4d = .false. + return + endif + endif + + if (allocated(rmask_local)) deallocate(rmask_local) + if (allocated(mask_local)) deallocate(mask_local) + end function send_data_4d + !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) INTEGER, INTENT(in) :: id !< id od the diagnostic field @@ -3635,6 +3913,11 @@ SUBROUTINE diag_send_complete(time_step, err_msg) & "diag_manager_set_time_end must be called before diag_send_complete", FATAL) END IF + if (use_modern_diag) then + call fms_diag_object%fms_diag_send_complete(time_step) + return + endif + DO file = 1, num_files freq = files(file)%output_freq DO j = 1, files(file)%num_fields @@ -3697,6 +3980,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) + + if (use_modern_diag) then + call fms_diag_object%diag_end(time) + endif END SUBROUTINE diag_manager_end !> @brief Replaces diag_manager_end; close just one file: files(file) @@ -3780,6 +4067,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + CHARACTER(len=*), PARAMETER :: SEP = '|' INTEGER, PARAMETER :: FltKind = R4_KIND INTEGER, PARAMETER :: DblKind = R8_KIND @@ -3794,8 +4082,8 @@ 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, field_log_separator,& - & use_refactored_send + & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, & + & field_log_separator, use_refactored_send ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN @@ -3810,7 +4098,11 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! Determine pack_size from how many bytes a real value has (how compiled) pack_size = SIZE(TRANSFER(0.0_DblKind, (/0.0, 0.0, 0.0, 0.0/))) - IF ( pack_size.NE.1 .AND. pack_size.NE.2 ) THEN + IF (pack_size .EQ. 1) then + pack_size_str = "double" + else if (pack_size .EQ. 2) then + pack_size_str = "float" + else IF ( fms_error_handler('diag_manager_mod::diag_manager_init', 'unknown pack_size. Must be 1, or 2.', & & err_msg) ) RETURN END IF @@ -3849,6 +4141,10 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF END IF + IF (.not. use_modern_diag .and. use_clock_average) & + call mpp_error(FATAL, "diag_manager_mod: You cannot set use_modern_diag=.false. and & + & use_clock_average=.true. in diag_manager_nml") + IF ( mpp_pe() == mpp_root_pe() ) THEN WRITE (stdlog_unit, diag_manager_nml) END IF @@ -3884,21 +4180,14 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) DO j = 1, max_input_fields ALLOCATE(input_fields(j)%output_fields(MAX_OUT_PER_IN_FIELD)) END DO +!> Allocate files ALLOCATE(files(max_files)) - if (.not.use_mpp_io) then - ALLOCATE(fileobjU(max_files)) - ALLOCATE(fileobj(max_files)) - ALLOCATE(fileobjND(max_files)) - ALLOCATE(fnum_for_domain(max_files)) - !> Initialize fnum_for_domain with "dn" which stands for done - fnum_for_domain(:) = "dn" - CALL error_mesg('diag_manager_mod::diag_manager_init',& - & 'diag_manager is using fms2_io', NOTE) - else - CALL error_mesg('diag_manager_mod::diag_manager_init',& - &'MPP_IO is no longer supported. Please remove use_mpp_io from diag_manager_nml namelist',& - &FATAL) - endif + ALLOCATE(fileobjU(max_files)) + ALLOCATE(fileobj(max_files)) + ALLOCATE(fileobjND(max_files)) + ALLOCATE(fnum_for_domain(max_files)) + !> Initialize fnum_for_domain with "dn" which stands for done + fnum_for_domain(:) = "dn" ALLOCATE(pelist(mpp_npes())) CALL mpp_get_current_pelist(pelist, pelist_name) @@ -3907,7 +4196,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) diag_init_time = set_date(time_init(1), time_init(2), time_init(3), time_init(4),& & time_init(5), time_init(6)) ELSE - diag_init_time = base_time + diag_init_time = get_base_time() IF ( prepend_date .EQV. .TRUE. ) THEN CALL error_mesg('diag_manager_mod::diag_manager_init',& & 'prepend_date only supported when diag_manager_init is called with time_init present.', NOTE) @@ -3915,12 +4204,16 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF END IF - CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local) - IF ( mystat /= 0 ) THEN + if (use_modern_diag) then + CALL fms_diag_object%init(diag_subset_output) + endif + if (.not. use_modern_diag) then + 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',& & 'Error parsing diag_table. '//TRIM(err_msg_local), err_msg) ) RETURN - END IF - + END IF + endif !initialize files%bytes_written to zero files(:)%bytes_written = 0 @@ -3937,22 +4230,10 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) module_is_initialized = .TRUE. ! create axis_id for scalars here - null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none') + if(.not. use_modern_diag) null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none') RETURN END SUBROUTINE diag_manager_init - !> @brief Return base time for diagnostics. - !! @return time_type get_base_time - !! @details Return base time for diagnostics (note: base time must be >= model time). - TYPE(time_type) FUNCTION get_base_time () - ! - ! MODULE has not been initialized - ! - IF ( .NOT.module_is_initialized ) CALL error_mesg('diag_manager_mod::get_base_time', & - & 'module has not been initialized', FATAL) - get_base_time = base_time - END FUNCTION get_base_time - !> @brief Return base date for diagnostics. !! @details Return date information for diagnostic reference time. SUBROUTINE get_base_date(year, month, day, hour, minute, second) @@ -3961,12 +4242,12 @@ SUBROUTINE get_base_date(year, month, day, hour, minute, second) ! module has not been initialized IF (.NOT.module_is_initialized) CALL error_mesg ('diag_manager_mod::get_base_date', & & 'module has not been initialized', FATAL) - year = base_year - month = base_month - day = base_day - hour = base_hour - minute = base_minute - second = base_second + year = get_base_year() + month = get_base_month() + day = get_base_day() + hour = get_base_hour() + minute = get_base_minute() + second = get_base_second() END SUBROUTINE get_base_date !> @brief Determine whether data is needed for the current model time step. @@ -4215,7 +4496,11 @@ SUBROUTINE diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name REAL, INTENT(in) :: att_value !< new attribute value - CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /)) + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + else + CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /)) + endif END SUBROUTINE diag_field_add_attribute_scalar_r !> @brief Add a scalar integer attribute to the diag field corresponding to a given id @@ -4224,7 +4509,11 @@ SUBROUTINE diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name INTEGER, INTENT(in) :: att_value !< new attribute value - CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /)) + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + else + CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /)) + endif END SUBROUTINE diag_field_add_attribute_scalar_i !> @brief Add a scalar character attribute to the diag field corresponding to a given id @@ -4233,7 +4522,11 @@ SUBROUTINE diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name CHARACTER(len=*), INTENT(in) :: att_value !< new attribute value - CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + else + CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value) + endif END SUBROUTINE diag_field_add_attribute_scalar_c !> @brief Add a real 1D array attribute to the diag field corresponding to a given id @@ -4242,7 +4535,11 @@ SUBROUTINE diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name REAL, DIMENSION(:), INTENT(in) :: att_value !< new attribute value - CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value) + else + CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value) + endif END SUBROUTINE diag_field_add_attribute_r1d !> @brief Add an integer 1D array attribute to the diag field corresponding to a given id @@ -4251,7 +4548,11 @@ SUBROUTINE diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name INTEGER, DIMENSION(:), INTENT(in) :: att_value !< new attribute value - CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value) + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value) + else + CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value) + endif END SUBROUTINE diag_field_add_attribute_i1d !> @brief Add the cell_measures attribute to a diag out field @@ -4272,6 +4573,11 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume) & 'either area or volume arguments must be present', FATAL ) END IF + if (use_modern_diag) then + call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume) + return + ENDIF + DO j=1, input_fields(diag_field_id)%num_output_fields ind = input_fields(diag_field_id)%output_fields(j) CALL init_field_cell_measures(output_fields(ind), area=area, volume=volume) @@ -4279,6 +4585,40 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume) END IF END SUBROUTINE diag_field_add_cell_measures + !> @brief Copies a 3d buffer to a 4d buffer + !> @return a 4d buffer + function copy_3d_to_4d(data_in, field_name) & + result(data_out) + class (*), intent(in) :: data_in(:,:,:) !< Data to copy + character(len=*), intent(in) :: field_name !< Name of the field copying (for error messages) + class (*), allocatable :: data_out(:,:,:,:) + + !TODO this should be extended to integers + select type(data_in) + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) + select type (data_out) + type is (real(kind=r8_kind)) + data_out(:,:,:,1) = data_in + class default + call mpp_error(FATAL, "The copy of "//trim(field_name)//& + " was not allocated to the correct type (r8_kind). This shouldn't have happened") + end select + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) + select type (data_out) + type is (real(kind=r4_kind)) + data_out(:,:,:,1) = data_in + class default + call mpp_error(FATAL, "The copy of "//trim(field_name)//& + " was not allocated to the correct type (r4_kind). This shouldn't have happened") + end select + class default + call mpp_error(FATAL, "The data for "//trim(field_name)//& + &" is not a valid type. Currently only r4 and r8 are supported") + end select + end function copy_3d_to_4d + END MODULE diag_manager_mod !> @} ! close documentation grouping diff --git a/diag_manager/diag_table.F90 b/diag_manager/diag_table.F90 index 7a23493657..5578bdaa38 100644 --- a/diag_manager/diag_table.F90 +++ b/diag_manager/diag_table.F90 @@ -250,12 +250,10 @@ MODULE diag_table_mod USE fms2_io_mod, ONLY: ascii_read - USE fms_mod, ONLY: fms_error_handler, error_mesg, stdlog, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase - USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type - USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE - - USE diag_data_mod, ONLY: global_descriptor, base_time, base_year, base_month, base_day, base_hour, base_minute, & - & base_second, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name + USE fms_mod, ONLY: fms_error_handler, error_mesg, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase + USE time_manager_mod, ONLY: set_date, time_type + USE diag_data_mod, ONLY: global_descriptor, get_base_time, set_base_time, & + & DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name USE diag_util_mod, ONLY: init_file, check_duplicate_output_fields, init_input_field, init_output_field IMPLICIT NONE @@ -325,7 +323,6 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) INTEGER, PARAMETER :: DT_LINE_LENGTH = 256 - INTEGER :: stdlog_unit !< Fortran file unit number for the stdlog file. INTEGER :: record_len !< String length of the diag_table line read in. INTEGER :: num_lines !< Number of lines in diag_table INTEGER :: line_num !< Integer representation of the line number. @@ -337,10 +334,10 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) INTEGER, POINTER :: pstat !< pointer that points to istat if preset, otherwise, points to mystat. CHARACTER(len=5) :: line_number !< String representation of the line number. - CHARACTER(len=9) :: amonth !< Month name CHARACTER(len=256) :: record_line !< Current line from the diag_table. CHARACTER(len=256) :: local_err_msg !< Sting to hold local error messages. CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: diag_table + integer :: base_time_int(6) !< The base time as read in from the table [year month day hour min sec] TYPE(file_description_type) :: temp_file TYPE(field_description_type) :: temp_field @@ -360,9 +357,6 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) diag_subset_output = DIAG_ALL END IF - ! get the stdlog unit number - stdlog_unit = stdlog() - call ascii_read('diag_table', diag_table, num_lines=num_lines) ! Read in the global file labeling string @@ -374,36 +368,14 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) END IF ! Read in the base date - READ (UNIT=diag_table(2), FMT=*, IOSTAT=mystat) base_year, base_month, base_day, base_hour, base_minute, & - & base_second + READ (UNIT=diag_table(2), FMT=*, IOSTAT=mystat) base_time_int IF ( mystat /= 0 ) THEN pstat = mystat IF ( fms_error_handler('diag_manager_init', 'Error reading the base date from the diagnostic table.', & & err_msg) ) RETURN END IF - ! Set up the time type for base time - IF ( get_calendar_type() /= NO_CALENDAR ) THEN - IF ( base_year==0 .OR. base_month==0 .OR. base_day==0 ) THEN - pstat = 101 - IF ( fms_error_handler('diag_table_mod::parse_diag_table', & - & 'The base_year/month/day can not equal zero', err_msg) ) RETURN - END IF - base_time = set_date(base_year, base_month, base_day, base_hour, base_minute, base_second) - amonth = month_name(base_month) - ELSE - ! No calendar - ignore year and month - base_time = set_time(NINT(base_hour*SECONDS_PER_HOUR)+NINT(base_minute*SECONDS_PER_MINUTE)+base_second, & - & base_day) - base_year = 0 - base_month = 0 - amonth = 'day' - END IF - - IF ( mpp_pe() == mpp_root_pe() ) THEN - WRITE (stdlog_unit,'("base date used = ",I4,1X,A,2I3,2(":",I2.2)," gmt")') base_year, TRIM(amonth), base_day, & - & base_hour, base_minute, base_second - END IF + call set_base_time(base_time_int) nfiles=0 nfields=0 @@ -656,7 +628,7 @@ TYPE(file_description_type) FUNCTION parse_file_line(line, istat, err_msg) parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units END IF ELSE - parse_file_line%start_time = base_time + parse_file_line%start_time = get_base_time() parse_file_line%file_duration = parse_file_line%new_file_freq parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units END IF diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 5591c293a3..216f14bad3 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -42,9 +42,9 @@ MODULE diag_util_mod USE diag_data_mod, ONLY: output_fields, input_fields, files, do_diag_field_log, diag_log_unit,& & VERY_LARGE_AXIS_LENGTH, time_zero, VERY_LARGE_FILE_FREQ, END_OF_RUN, EVERY_TIME,& - & DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, base_time,& - & time_unit_list, max_files, base_year, base_month, base_day, base_hour, base_minute,& - & base_second, num_files, max_files, max_fields_per_file, max_out_per_in_field,& + & DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, get_base_time,& + & time_unit_list, max_files, get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,& + & get_base_second, num_files, max_files, max_fields_per_file, max_out_per_in_field,& & max_input_fields,num_input_fields, max_output_fields, num_output_fields, coord_type,& & mix_snapshot_average_fields, global_descriptor, CMOR_MISSING_VALUE, use_cmor, pack_size,& & debug_diag_manager, flush_nc_files, output_field_type, max_field_attributes, max_file_attributes,& @@ -57,8 +57,9 @@ MODULE diag_util_mod & get_axis_reqfld, axis_is_compressed, get_compressed_axes_ids USE diag_output_mod, ONLY: diag_output_init, write_axis_meta_data,& & write_field_meta_data, done_meta_data, diag_flush - USE diag_output_mod, ONLY: diag_field_write, diag_write_time ! @addtogroup diag_util_mod !> @{ + ! Include variable "version" to be written to log file. #include @@ -645,10 +647,11 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& CHARACTER(len=256) :: lmodule, lfield, lname, lunits CHARACTER(len=64) :: lmissval, lmin, lmax CHARACTER(len=8) :: numaxis, timeaxis + CHARACTER(len=1) :: sep = '|' + CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range - CHARACTER(len=256) :: axis_name, axes_list IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN @@ -1194,7 +1197,7 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n files(num_files)%long_name = TRIM(long_name) files(num_files)%num_fields = 0 files(num_files)%local = .FALSE. - files(num_files)%last_flush = base_time + files(num_files)%last_flush = get_base_time() files(num_files)%file_unit = -1 files(num_files)%new_file_freq = new_file_freq1 files(num_files)%new_file_freq_units = new_file_freq_units1 @@ -1208,7 +1211,7 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n IF ( PRESENT(start_time) ) THEN files(num_files)%start_time = start_time ELSE - files(num_files)%start_time = base_time + files(num_files)%start_time = get_base_time() END IF files(num_files)%next_open=diag_time_inc(files(num_files)%start_time,new_file_freq1,new_file_freq_units1) files(num_files)%close_time = diag_time_inc(files(num_files)%start_time,file_duration1, file_duration_units1) @@ -1222,8 +1225,8 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n END IF ! add time_axis_id and time_bounds_id here - WRITE(time_units_str, 11) TRIM(time_unit_list(files(num_files)%time_units)), base_year,& - & base_month, base_day, base_hour, base_minute, base_second + WRITE(time_units_str, 11) TRIM(time_unit_list(files(num_files)%time_units)), get_base_year(),& + & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second() 11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2) files(num_files)%time_axis_id = diag_axis_init (TRIM(long_name), tdata, time_units_str, 'T',& & TRIM(long_name) , set_name=TRIM(name) ) @@ -1266,75 +1269,6 @@ SUBROUTINE sync_file_times(file_id, init_time, err_msg) END DO END SUBROUTINE sync_file_times - !> @brief Return the next time data/file is to be written based on the frequency and units. - TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg) - TYPE(time_type), INTENT(in) :: time !< Current model time. - INTEGER, INTENT(in):: output_freq !< Output frequency number value. - INTEGER, INTENT(in):: output_units !< Output frequency unit. - CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message. - !! An empty string indicates the next output - !! time was found successfully. - - CHARACTER(len=128) :: error_message_local - - IF ( PRESENT(err_msg) ) err_msg = '' - error_message_local = '' - - ! special values for output frequency are -1 for output at end of run - ! and 0 for every timestep. Need to check for these here? - ! Return zero time increment, hopefully this value is never used - IF ( output_freq == END_OF_RUN .OR. output_freq == EVERY_TIME ) THEN - diag_time_inc = time - RETURN - END IF - - ! Make sure calendar was not set after initialization - IF ( output_units == DIAG_SECONDS ) THEN - IF ( get_calendar_type() == NO_CALENDAR ) THEN - diag_time_inc = increment_time(time, output_freq, 0, err_msg=error_message_local) - ELSE - diag_time_inc = increment_date(time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local) - END IF - ELSE IF ( output_units == DIAG_MINUTES ) THEN - IF ( get_calendar_type() == NO_CALENDAR ) THEN - diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_MINUTE), 0, & - &err_msg=error_message_local) - ELSE - diag_time_inc = increment_date(time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local) - END IF - ELSE IF ( output_units == DIAG_HOURS ) THEN - IF ( get_calendar_type() == NO_CALENDAR ) THEN - diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_HOUR), 0, err_msg=error_message_local) - ELSE - diag_time_inc = increment_date(time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local) - END IF - ELSE IF ( output_units == DIAG_DAYS ) THEN - IF (get_calendar_type() == NO_CALENDAR) THEN - diag_time_inc = increment_time(time, 0, output_freq, err_msg=error_message_local) - ELSE - diag_time_inc = increment_date(time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local) - END IF - ELSE IF ( output_units == DIAG_MONTHS ) THEN - IF (get_calendar_type() == NO_CALENDAR) THEN - error_message_local = 'output units of months NOT allowed with no calendar' - ELSE - diag_time_inc = increment_date(time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local) - END IF - ELSE IF ( output_units == DIAG_YEARS ) THEN - IF ( get_calendar_type() == NO_CALENDAR ) THEN - error_message_local = 'output units of years NOT allowed with no calendar' - ELSE - diag_time_inc = increment_date(time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local) - END IF - ELSE - error_message_local = 'illegal output units' - END IF - - IF ( error_message_local /= '' ) THEN - IF ( fms_error_handler('diag_time_inc',error_message_local,err_msg) ) RETURN - END IF - END FUNCTION diag_time_inc - !> @brief Return the file number for file name and tile. !! @return Integer find_file INTEGER FUNCTION find_file(name, tile_count) @@ -1738,8 +1672,8 @@ SUBROUTINE opening_file(file, time, filename_time) match_req_fields = .FALSE. ! Here is where time_units string must be set up; time since base date - WRITE (time_units, 11) TRIM(time_unit_list(files(file)%time_units)), base_year,& - & base_month, base_day, base_hour, base_minute, base_second + WRITE (time_units, 11) TRIM(time_unit_list(files(file)%time_units)), get_base_year(),& + & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second() 11 FORMAT(A, ' since ', I4.4, '-', I2.2, '-', I2.2, ' ', I2.2, ':', I2.2, ':', I2.2) base_name = files(file)%name IF ( files(file)%new_file_freq < VERY_LARGE_FILE_FREQ ) THEN @@ -2118,195 +2052,6 @@ SUBROUTINE opening_file(file, time, filename_time) if (associated(fileob)) nullify(fileob) END SUBROUTINE opening_file - !> @brief This function determines a string based on current time. - !! This string is used as suffix in output file name - !! @return Character(len=128) get_time_string - CHARACTER(len=128) FUNCTION get_time_string(filename, current_time) - CHARACTER(len=128), INTENT(in) :: filename !< File name. - TYPE(time_type), INTENT(in) :: current_time !< Current model time. - - INTEGER :: yr1 !< get from current time - INTEGER :: mo1 !< get from current time - INTEGER :: dy1 !< get from current time - INTEGER :: hr1 !< get from current time - INTEGER :: mi1 !< get from current time - INTEGER :: sc1 !< get from current time - INTEGER :: yr2 !< for computing next_level time unit - INTEGER :: dy2 !< for computing next_level time unit - INTEGER :: hr2 !< for computing next_level time unit - INTEGER :: mi2 !< for computing next_level time unit - INTEGER :: yr1_s !< actual values to write string - INTEGER :: mo1_s !< actual values to write string - INTEGER :: dy1_s !< actual values to write string - INTEGER :: hr1_s !< actual values to write string - INTEGER :: mi1_s !< actual values to write string - INTEGER :: sc1_s !< actual values to write string - INTEGER :: abs_day !< component of current_time - INTEGER :: abs_sec !< component of current_time - INTEGER :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) - INTEGER :: julian_day, i, position, len, first_percent - CHARACTER(len=1) :: width !< width of the field in format write - CHARACTER(len=10) :: format - CHARACTER(len=20) :: yr !< string of current time (output) - CHARACTER(len=20) :: mo !< string of current time (output) - CHARACTER(len=20) :: dy !< string of current time (output) - CHARACTER(len=20) :: hr !< string of current time (output) - CHARACTER(len=20) :: mi !< string of current time (output) - CHARACTER(len=20) :: sc !< string of current time (output) - CHARACTER(len=128) :: filetail - - format = '("_",i*.*)' - CALL get_date(current_time, yr1, mo1, dy1, hr1, mi1, sc1) - len = LEN_TRIM(filename) - first_percent = INDEX(filename, '%') - filetail = filename(first_percent:len) - ! compute year string - position = INDEX(filetail, 'yr') - IF ( position > 0 ) THEN - width = filetail(position-1:position-1) - yr1_s = yr1 - format(7:9) = width//'.'//width - WRITE(yr, format) yr1_s - yr2 = 0 - ELSE - yr = ' ' - yr2 = yr1 - 1 - END IF - ! compute month string - position = INDEX(filetail, 'mo') - IF ( position > 0 ) THEN - width = filetail(position-1:position-1) - mo1_s = yr2*12 + mo1 - format(7:9) = width//'.'//width - WRITE(mo, format) mo1_s - ELSE - mo = ' ' - END IF - ! compute day string - IF ( LEN_TRIM(mo) > 0 ) THEN ! month present - dy1_s = dy1 - dy2 = dy1_s - 1 - ELSE IF ( LEN_TRIM(yr) >0 ) THEN ! no month, year present - ! compute julian day - IF ( mo1 == 1 ) THEN - dy1_s = dy1 - ELSE - julian_day = 0 - DO i = 1, mo1-1 - julian_day = julian_day + days_per_month(i) - END DO - IF ( leap_year(current_time) .AND. mo1 > 2 ) julian_day = julian_day + 1 - julian_day = julian_day + dy1 - dy1_s = julian_day - END IF - dy2 = dy1_s - 1 - ELSE ! no month, no year - CALL get_time(current_time, abs_sec, abs_day) - dy1_s = abs_day - dy2 = dy1_s - END IF - position = INDEX(filetail, 'dy') - IF ( position > 0 ) THEN - width = filetail(position-1:position-1) - FORMAT(7:9) = width//'.'//width - WRITE(dy, FORMAT) dy1_s - ELSE - dy = ' ' - END IF - ! compute hour string - IF ( LEN_TRIM(dy) > 0 ) THEN - hr1_s = hr1 - ELSE - hr1_s = dy2*24 + hr1 - END IF - hr2 = hr1_s - position = INDEX(filetail, 'hr') - IF ( position > 0 ) THEN - width = filetail(position-1:position-1) - format(7:9) = width//'.'//width - WRITE(hr, format) hr1_s - ELSE - hr = ' ' - END IF - ! compute minute string - IF ( LEN_TRIM(hr) > 0 ) THEN - mi1_s = mi1 - ELSE - mi1_s = hr2*60 + mi1 - END IF - mi2 = mi1_s - position = INDEX(filetail, 'mi') - IF(position>0) THEN - width = filetail(position-1:position-1) - format(7:9) = width//'.'//width - WRITE(mi, format) mi1_s - ELSE - mi = ' ' - END IF - ! compute second string - IF ( LEN_TRIM(mi) > 0 ) THEN - sc1_s = sc1 - ELSE - sc1_s = NINT(mi2*SECONDS_PER_MINUTE) + sc1 - END IF - position = INDEX(filetail, 'sc') - IF ( position > 0 ) THEN - width = filetail(position-1:position-1) - format(7:9) = width//'.'//width - WRITE(sc, format) sc1_s - ELSE - sc = ' ' - ENDIF - get_time_string = TRIM(yr)//TRIM(mo)//TRIM(dy)//TRIM(hr)//TRIM(mi)//TRIM(sc) - END FUNCTION get_time_string - - !> @brief Return the difference between two times in units. - !! @return Real get_data_dif - REAL FUNCTION get_date_dif(t2, t1, units) - TYPE(time_type), INTENT(in) :: t2 !< Most recent time. - TYPE(time_type), INTENT(in) :: t1 !< Most distant time. - INTEGER, INTENT(in) :: units !< Unit of return value. - - INTEGER :: dif_seconds, dif_days - TYPE(time_type) :: dif_time - - ! Compute time axis label value - ! - ! variable t2 is less than in variable t1 - ! - IF ( t2 < t1 ) CALL error_mesg('diag_util_mod::get_date_dif', & - & 'in variable t2 is less than in variable t1', FATAL) - - dif_time = t2 - t1 - - CALL get_time(dif_time, dif_seconds, dif_days) - - IF ( units == DIAG_SECONDS ) THEN - get_date_dif = dif_seconds + SECONDS_PER_DAY * dif_days - ELSE IF ( units == DIAG_MINUTES ) THEN - get_date_dif = 1440 * dif_days + dif_seconds / SECONDS_PER_MINUTE - ELSE IF ( units == DIAG_HOURS ) THEN - get_date_dif = 24 * dif_days + dif_seconds / SECONDS_PER_HOUR - ELSE IF ( units == DIAG_DAYS ) THEN - get_date_dif = dif_days + dif_seconds / SECONDS_PER_DAY - ELSE IF ( units == DIAG_MONTHS ) THEN - ! - ! months not supported as output units - ! - CALL error_mesg('diag_util_mod::get_date_dif', 'months not supported as output units', FATAL) - ELSE IF ( units == DIAG_YEARS ) THEN - ! - ! years not suppored as output units - ! - CALL error_mesg('diag_util_mod::get_date_dif', 'years not supported as output units', FATAL) - ELSE - ! - ! illegal time units - ! - CALL error_mesg('diag_util_mod::diag_date_dif', 'illegal time units', FATAL) - END IF - END FUNCTION get_date_dif - !> @brief Write data out to file, and if necessary flush the buffers. SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time) INTEGER, INTENT(in) :: file !< File ID. @@ -2332,7 +2077,7 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, static_write = .FALSE. IF ( PRESENT(static_write_in) ) static_write = static_write_in !> dif is the time as a real that is evaluated - dif = get_date_dif(time, base_time, files(file)%time_units) + dif = get_date_dif(time, get_base_time(), files(file)%time_units) ! get file_unit, open new file and close curent file if necessary IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) & @@ -2367,9 +2112,9 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .TRUE. ! *** inserted this line because start_dif < 0 for static fields *** IF ( .NOT.output_fields(field)%static ) THEN - start_dif = get_date_dif(output_fields(field)%last_output, base_time,files(file)%time_units) + start_dif = get_date_dif(output_fields(field)%last_output, get_base_time(),files(file)%time_units) IF ( .NOT.mix_snapshot_average_fields ) THEN - end_dif = get_date_dif(output_fields(field)%next_output, base_time, files(file)%time_units) + end_dif = get_date_dif(output_fields(field)%next_output, get_base_time(), files(file)%time_units) ELSE end_dif = dif END IF diff --git a/diag_manager/docs_uml/MDMClassObjects.drawio b/diag_manager/docs_uml/MDMClassObjects.drawio new file mode 100644 index 0000000000..890182f218 --- /dev/null +++ b/diag_manager/docs_uml/MDMClassObjects.drawio @@ -0,0 +1 @@ +7T1bc9s21r+lD5pJdyYe3nR7dBynm9a51En3S/rCoURKZkORCi+xnV//ASABgSRIAhBJyTU62o1F8QAHwLnj4GBiXu0efoud/d27yPWCiaG5DxPz9cQA/2kz8A988pg/0fXFMn+yjX23eHZ48Mn/6RUPteJp5rteUnoxjaIg9fflh+soDL11WnrmxHF0X35tEwXlXvfO1qs9+LR2gvrT//Pd9K4YmGkuDz/81/O3d0XXpqkVmO8c/HbxILlz3OieemReT8yrOIrS/K/dw5UXwOnDE5PDvWn4lWAWe2HKA/CHtrIe36dvv2fLW+t74uw/Z7+/LFr54QRZMeKJMQtAe69W4I8t/GOzS177zvbD6h8wwXb6uPfwK6Av8lYxxvQRz9xdugvAXzr4LfrhxZsAjX0VROtvsHX476e9s/bDbfFWcu/vAicE4K/Wd37g3jiPUQZHlqTO+hv+9uouiv2fUZg6uPXDg0/wRfBUA09jLwHE9BHPjl559M55KL144yRp8WAdBYGzT/wVGgl8sgGtfypGBr/vnHjrh6+iNI12xSOM/Bs/CK6iIIrRJJgb9B/8PXXitCBvYwoe3N/5qQcnAD65B9yD+8nf0WcX8+IJ1ZzpWLrlgOdO4G9D8GwNhuLFsH0ylQibNI6+eSzA/JcP8O0U8qSuoTmIstD13GKenFUSBVnqXcZrjA18Sr4tSTuYJbSLBSEBmiAxdXlx6j1QjwoC/c2Ldl4aP4JX8K9zzD6FwMDMc39gvumieHZH8d1sVjx0CobfkrYPLAH+KLhCgEOMGoesAydJXhRsARYcTDSgPj/0YsQdv06MK4hIAEjcSR1IRmAU5iX8GNqbd59sF8DZGwCYgAcvwPNfCdPFB37SoFgrd+UFrlgXACBp7QC2htt/lW02Xiw1mBUCbe/KB6S6BcSKGtzH/g8nLTUWe1s/AdTsubg59CuYcUgT2i+gNWcH2SQgbZrg/6NNCRZ8IdBvXH/nhYkfhVzze/ngJyKjRyN3AFBfw/7hxD7sJBEaLgV1NAZwNEKd5wDsfoNo6wNN2tivH/qpDyTZTyR5LjZOkHgXzN592G96h3CLkB6CD+G3MEorLUkig9jRbkBJtknIfv22WdB2v406D81Dr2h1IN2xOqUUfK5DiR1UV0FhhPT6htKOxSOsyQJvAxGGqgLielk83vmuC/vGCu4GvfbaOjy5LTq1yobGHQD0QqTb0oJ1c8T2EeAHpCSmr8AHzM+VdjGdTF/D6Zm+0g/fwQe+HgMNHILhALEA+/GApXDvQWuBQ+mzlO1xmr+uZFvtum7NixXtlE/RGtZ0IEVrMkzRCvUFPqKZsvGh90JYnyOwDq9f6jVSM+ukZjLIKnBWXvAxSgATRbD9OH+3Qm5dFDXY6s457ajFQItr1RZ3H0drz83imkrAWp9IMKCecysjF/12/hLwLE1dIzIu/zAbRbBe6HY2jN7hbxeCY2VIGVx2AsjMiftoCXiwzqN0Q8DnACSfNyXaCLFthGcbd8+cbdYgweRDpQ+0vvYOWBXBY0mhEz16ITWEYh5d8L80jf1VBjWf7FQc1czWS2032gGeN4RXA8IiDAIv3AL+len6MBu+a2/iaGeHzk5qFAgTCJw340sS13rt7QFeQIpKwSeAW+11tNsHnuSaupHtRyVI09+4HrQ1s8SzHx1g3wi0S2Y5t9HKDQNkoRGrrKlnYk3NF3z61lwYx2vcUPvz91evfg8//+/b+lK7CXY3v719qeNICkVvnrv1cCALrMRdtI1CJ7g+PKUiQXByD+/cRMg+guT5j5emj8X0OlkalYnXe/DTL9TfX1F4CIW84NfXOOyGvjziLyEY8Rf6SwFmWPjBARB9K0F+9GLg6KNA2GutLRCVRFm89tomrQgxOzHg5u6gEJzPVnIA6gzo4B/lYDJrqQvQj5CdJodw2GxZDoeRRcVt5JgWYAeKucwNB/JawaaNHS2w+V/0Y87LoeSO1zFaB3rNEThQL5mTIwiaO1TNCmSpmLWKWQ8Ts7Y6I9bWlBWx7sHVYvJJR8A6Zw4bPeOIb+bGTG6k16NLyp45d3umVZQeEx1iErXZQ3CIibEKDg23uDNOiTWUwMIpAW2LO4LlKm81TsexBs3K3uiSzxbsy/6adttfQAsDwl2nFXe7qnaULaZssWFsMaPiLs0Zuxozhmgzqn5Vb8Jt1sg1YMrDEsnPvmcRYidAhVs0pS/X+RJQu6VonvCbmHlKO7wla651GzEP3WFWzPHB3Fi39fInrv+Ds9dsFfhrutMw29le4O3A8uItc8Zeb5agjWUfzk0K3PqXDlh+ZwuJ84ArhQUDsdze/Q/LumVjtgaTndqaW9rI7+ymGP8L37K/+aH7a1PrxWRXvND2tscnkia0XX/XslrpHaSrJA/Uo/QAz1nfIeehknrRQGHVmVAexZP0KKbckrplv5klmXVtKJdirlyKwVZXNxn7zazlHcynaFS7lLRhbw8FWXJ32MPhE9cNO6E7Z99LS4mX2iyVrSTnM5ScusnYW2Lx1myorSWDJTorrqD3kHqh2xR1rFoZmquC9MoxHDKxfFr2DC1GQpRlsuyP+VCeodGso3q0+lt8oSoTNlv5h2ZJbtOhmwZHscHeH3toyLVrG9uLBwAPVvPqZ94O8jmjzUvXefx1vLEIzKPS809SzxOledSmC0tETYfykAyOwLxykWSXd8GpgcRdJHJEAs1AISZYfkUhMz3ipFRSNiu/25pbS4hrTOPN0zebWq69wd02TMJMo0aM6V+529wS/6rWIPwJNmN0MYupUatdcJcS089ATC/q7hibj8XdMfC14GWRrfJ6rv2R3pmuvDPlnY3pnc24vbM+jv2yuah5u/uk3plyt5S7pfR4tx4nWrB3d6uPA5BslFm5Asrd6ml5eVXKCdytXEI2OV26y5JWEr5XuZu6BybYEdsRq4yl5I4JdsDwysqtwxd0Lt9srnyzZynTGcewTuubNcf8JX0zQ/lmyjcb0zdbTE/vm7Hi0qf2zeBrT8xDIygrP03p9FPp9AW3QDoXPw0f+FN+2hDL+2T9NGMsP02wI3E/TbADLj/N4PHTLJo0lJ/2fGT6uflpltG3n2YqP035aWP6abrGyMEf2VGzWMe2z8NRe7LuWgVx5YMpfX2sviba7gn5YKwkF+WD9bS8T9YHM8fywQQ7EvfBBDvg8sFMLh9sqnywZynTz84Hay6dIOmDWcoHUz7YqD4YucfohD5Y82HN8/DBnrgnpvwxpbv71t0zbsFzNv4YK7FF+WM9Le+T9cessfwxwY7E/THBDrj8MYvLH1sqf+xZyvRz88ewbdufPzZV/pjyx0b1x8zlyf2xaXMd+3Pyx/4VXpnyzZQe77tcl8YthM7FN5uyklmUb9bT8j5Z32w6lm8m2JG4bybYAZdvNuXxzaam8s2epUw/N99syfLNKiJ+jMu/yD1eFzN9PqHu8tIvNG0x6fMuL/qOrrYSsIPfyjAr34VlVQsG5tdH1K5lYDRUKVE40F1fNYTHuLxraZ2EHvFldID6yhfSabPlhO9GuoulsSxRsgwVw7b7u6UOy6tzYYFZ5WIS3TIr1g4vD5A7ErHtbAzDA9V+9AoT1IdYjSSIAlh6+/tTq/X9gbhyfmItMZ8uK1rC+lcqiSq9mRYfXXc2NKteAtTAaaIMMtPZ/TSSe+V9fIFU0/uWNW17fyByX5xaCRllJTQ3eJXQYmpVGUXKnOpXEWExfz5sppfVR9UW60l9zMwytS+KUuuN3FF5H/sKjdyBKZX9/kDcsTwld7zU6uyxtHjZQ59XvQ3TOD174BzMs2GPeUULLSohx57YQ9eXZWNJK6T9sPcDa/w3BL/xA0/dD6w2IcfYhDSmlUu8GQVU2HfDD7YHqWv1LYHiZkbtBcUiiDPa99/evPtko4uCNz78Qe1qPckI6EF2HnWBF4uKjaG2tXRNXQo85ALziqmhrvACVkOjPu+6MMtP7Njb+tASpRS7xM1boCEo2Gyg61J4PeIxbUV7L6Rl5TFt3cdAKtiwKJMNZttxAWVxNzhA3kMLjs4DmEMGjjyXQYrMxcb3Ald8Mrow76cxIArsKLTTO9CiwC2gTSSJ1j2NbIRnb62tgyjx+qXN42cv27twzzr0HtI+hls0t85iKDBBs/c5f29i77vtA4Px4cjpDNcxkM6enYWBvwPoujbrJlSJlvPV6RQfygB7LgbYlHENINONwMZ+/xoaB31Ptn8AA29U3Afu60nvz32h/v5K/c0OPslHhchS02GhP7SV9fg+ffs9W95a3xNn/zn7/aUxTlio5qBW/c6e9hQMa8F0hJuioLX3ZyNEQXVdLIqkgkcTFTyaDBY8Mq1FeaOMUdRpxpL6h1T3AcR+PXpELpenTCG3KSvv89eP1y9yqzOPLx2AEFkg2zF/tfKp16n9nF9AD8EmeZVa8M8mgpjkd9PTxpIAIgGgfxsw2D5LudDIO442pF/YwAEj0tK9k2ATOZRAC9nBx6AFG8AIyPZfRkKg12M7j+xdFGOvgm/owHiA5AFMC6gn157/A0oFQyvawJTiJ/KkgqYDmee8NEuhhuG6iTWIttDSZvZRfKpRCxhx6MTm4nOceRcQalPBQ0OzAhvxGnk5P6TxZpe899K1u8lVYnvIGDYerf5hIgM0q2H70QEFnATN7h2uxQvoE311dgHsO6FD1sggKQsl5D89gpcLJ4qZ/xtmQfCCefQF9kmJupE/eBBwiHa0sd1oB5yc9pWBA36N3iPLQk2LLAYdPd85sbOGp3IC6NK9zs/gaHnvxB0u7ojqIBQS0QEuerQD/O96QefKCPcDQ0e+mzBJ8u1r+HwdxcAw2kehm8uPFNOo/cOJAz9pJFFZpBCRSuCUMzCExiPrFChNmO1j/4cDJXXn3MFgawIWvFlOlKah0lbf/BFmOwqjPDLInkdgCU4KRUXeosdCT2mbbJZdZBRiRIvcb7vFwYgm8nEKzw0NnByFyN8GQiNa+2DZ4fDvfWBkCk1AaRVWAAcgp+Aou6a/eAcKFTFdSIQi1M3Rnt1RWccVon+dJwBACMDDPpxDZAXkJkFhw+y92Emp4B3HwJmhv0bTlbxNrzDELg9RBnCdVl7O4NBwarEbGbMCyAtvXfCq/tj7nnnh+nFS6P+Xes2VVVHFJxJV1PvY1mX6l9ZssH1dXe3rDrnCFuMMPHOJB9vY1esbu9SWB7I8slWAZFbpVGBuazihaxfG0aTldm92M3dO4RqxzUrJ1pA3IwNcdUdE20i8tPAC8nHkWlSmFTQpxKwXbAAujvPgSXQNIemYjzTqB/Uvt4jEAxAFh4dFS5T4C1TtH15/EIAvecQF8DHt1bxcRrOC6PXDMHlr9bn+hZhDmwhYtPe5ubPJ1lCG5q4OMsfufSReMipkUng6fvg985GY22QhBqPR4x/pJnSqpCgADM2n0E+PgZeFhTxwTN/IFAU2qCx8kq2KtBvZFkr78ZKNwNVjSBNJJGw4odKk1CTa+FsAL2H/4yj448ZxiHFIgW+DaOUESIQINkH0tQxTHoDlmLIELwsryZQEXpIpCbw0U5IWjmFKdiNSxHgYkSxTkRYkmaoGf9w45JiKgMszlZvt9sUGATQ6lHP/XJx7cq6s0/VbDpczND1JzhB9zKxSCkDjLAVAMotyuOmkI9Go17NkZLU7D5ORwx395Q0dueLNFchJtkylcCR9+IRy9rLVbZHVrVJvJir1ZtKcegMlQJK/0sp3Apk400X5UK5OjlPSVYDwlWe0NF22RNKK/m69deqEW+Ss4/S32dwsd2jhB3SHBkN84yQh3KETgJUJndR7BSc3qbF0L3lz9QrgsrtX0GTt2hlj7HXkeef1NHvObZJslSf8exsf5Tsos+iJmkVzbtZuqdDI4uMBtzxYN9qrLY++FphV9Ze1wIPteDCWc0SjF3A1cBBLNq8+5bN5tQsrr8JAF3I7gxJYhAi6zWG82zR4Gv1iUdXXRkUPN9RX6E0HG6ep59TmW1m8dDafz8r+lW6eA50ZZp3ORjysIXzGwqyesSiMz8ZDFlWA+bxCmkMcsjBYW/xNhyzgdpFy9ZSr1+Dq9eDbGdNZlWvqFgO7uoFW9bV6NBrqaRI5G2jllOf/OXFjoQ6W50UFgvPTpC05ouRT8uWO/AhgiKLULW4gG79aBySTtYfsUjRpcMe/A6CebpeF/vfMy9cd5xnizMMjB1ifQfGB0UmjHcigvPtCQF+maeyvsrStWkxX1w5uIynwH4Aa+6QBmGF8wLkT3VKm9aDEWa5TcQYIdWeGnwCpnZN8sxHnhY15+ydAy43sMEpt0OEZIQWbbjxxQT68DCmPKsYHLBttDDZixD6Ectx0UTgU6QinwyGIwu3JkQDiJnRPjgXehT8dBrvo9LMQe06wOykG6FjZHmYk3EWCFmWnQdOOEDEXD4cXzsZeTKEJi66pOsmUdG2kHCij87zgQbbzzc9Br7WdFiSft+8/X/92fXvUpFc/PItJForrWOUJKAi4tk7e6g/gIfOImeab03rBjYg9P0lgaavcQz0XrFCW8u3l+9+u+ZyJDrxKbDcxGLfLVbAv4YFP152NPUdhZeMroc7LNk/v7NDz3ATd8AQPJYSe2o19qruxJNLbe2HRmTbYdixGQW3HDrLCM0YRm3FLixqz2gI3XhWXh/rgO0QybnbF0a3a4Z+KVGPXCHTzMzS5x1Bp+hCStcvvCXWxjvaPtabhwxxt1nm19gZxGIc5FfhHm0K+OM4ED/a882IPHWM+XA04weftLwTxSLz07esaEgk+8yS8FhCyCKrXmzyEGkSbLKl+FrIl00C09QYVyein4U2hHtHhPhzrbKPXyotCnRRTbfvh91oX93cO4LKEsRyQuq7uvPW3SeOxr25upE7IM4YG6NimXhFtulRMotw8lB2l6Kh0069aUT+mj3KglDGASiRVsPkitshoF0cd6ZV+S1dqmBwuNIVTu26hgl8OpyfbMSIncvGWmMhwCLCwDIKQpc0EUWAp4oSA0qQBgY9YegheXWFeODmhXEBKqNIcVxJrlVgbEiEVhWWcLuJbmUi2RxxDFIWrRv5E4em4nShsKb4mzHcotCJOSjgOI7w0lYiJsIQhsQ1Z4JrVAUXrbx4U77IqFApsaQEGgaUE2FH680jdxVJRvHByAqyAlODrHFcpAVasjZQAg7AyAgytjJQAywlCXIAhJ+4IAYaOOUsKMAgrLcAQ34kLMERKMgIMLc0RAmyLPR8ZAYYGm+9lCEIWx12JVyqOM7ssCsfKVncURD09Kv1JGGl/B3lIBhTIGTv55ocyjIAlDX09hUgbDZd5iMt2FUV+1lHkmcl5PYJuDnfWeXrSKzWLI8pc1xlQifjU+Y48ER9eGN/npcwcSfeMe2VPeUOCrs/KF8vqnPc3C9+caRhauSPTGiMdv352c9KQjn8JVLC6OVOl5Y+Rlq9r0zI3EO6ghDq5Sp0W6tV7n3vcOaqf1MzzByj+4Lg2My/Up8yRJ2qOLLhJuXlTm0m45mB72njPVe1pD7LAM07JpA8mmczZSY1N2tS8aD9dLG8ZWvNxDL7KmUhyRrL/g7zu2/APw7l7u8r+/jmNPm6+2l8eGRW3z99tID7CV9yeqMNQkcoa+O/Nm6q1NDvOszC5j41jeXkuVZRMjipKVRtEmebKNB/KNLfmF5WbyeYsG2daV4HEiherhzQ3uvvT5yybqtLdGNWQzLpH3Xt6e0PaMQmSN4LWT6ainCrqvq6ijngtJ1g5LE/TYTH7qInEZubhHBZVE2nIBcahla4FHiwHF3tHPDm4+QQw9v+at61hOTeP923UcGXLWeBOe14QntfzGxHibJ1m8PIq6vhW95jLYF0gPswwomC2MZwsJeKfi4hnXCDOlAD6rIcNMqafaz4VP5fbNaUcYkNfllziC+3wYKR9NMvg9XaxMB58J40EwHDcrBoQG2onbTad0u0x9vgMsw1goK03vEQCxZHpLYaDNC9+/JStlPs/Ue7/ZFD3fzkr++JzXGSRzrbAnF3WJVK+/2xWjTbMGfarZTJ6PIX3b9XL21399/L28urz9W2t7sLlzc2Hq8vPl69urlmnaUk6WFGfuLvORI+BhhZ0IKPAREAfUOTDGSDkoVtwedBBxatILfmDJJWZBdzKGUxA1UdShvx5GfJhdANDAo3ai9fQJxbDUSeqmcK57UQ1QzgLNl8NFY0iies1FFUQqT/K0lknuVlrP1wUqX5UnxnsgGuJa/wr2XhusnFICmXkATOl01BBjrrAGTHIUSrH3RrioCIXs8WiErmwzI7IhViApM8QB/eG/kAhDuHAhIX3KPHlBIVL1BiYmC6OBJhNOwCMxbQNYKjQh/i9UK2hjzdZEKjYx0TFPibDxj4a+LekYTSGhqmFOnu0gurpBs0Bh/zTFnYopRJwFbbsoze+Mp599AQPqcmNSxesrd2EwRpeYcqHwc3lp0+kOl37h3tN4UYkX3G8PqabHIPMtz85yyoeHytpXYHCF3jx7vKL/emvV5dfrj8J1B0fGLmQeCpSRTv56eBElTm7COW80AKUvwWS/VzQcf3YW6edQcdJP8wLzWVJJQDsSn5x2USmWUc0d6B+86uuz2PB6QIBVaB6Lt9nlMEXZrsVElR5Vh+8J6RzPJ+/frzmv9WhacEEr3IYaxIFr2wYjZlzsb3HMT75qsOyGFAZQL6LF00FyJ5ogKyPRE+m92INV27VUpmeQ66wxQrSs5Z4sCA93qunFvjj7Yer69d/3V6XdIdbJDxylJFkNtBYprRcohT10VoLho0eBMPGYKUDkkVKjEWRlmGtl5KhJQrcWRmHCQmRXke7PVTzXTVqGhvwQ9dft9WZaYTcBtHKCWw/Ip0rtfNc1I7F2pdhCSV93sPGzMfk7w/Rzz+1L6l//9L9K/34NbnCpyzbws/0PXv4mj0VWVaR5YEO1c0to5LmtsBbOXSa25J1TAPzTu9sYtTYhNwhBB7XIgvEw2ipfgELjG3aQgq99NBxSxdnLE+kR+BDZa2RmV7GtYvcrPnCyAGGVZSCG25EQLYNTg1d96X10knrFgasTfkCzSXwESw0q523ODE/dI8/Vyh56oXRGGmRIQjusAaJrgDDOgPs1nhT4ChY7KP79ruIGIuM4v+fb+2b6/e/Vi78gS+hhq/yTgSJgY42KcP23A3bVhPxmGgKU10bsx6iKUyUWTerq1hKT6vLuBacbY0NtLj1bNbWIq6tNlYrZIft1ArbaQW1QrdbN62gbXZKK2CH/dEK22VXtAK32gutkIXel4Lt3gZpBO/U881HuLt0c9MZ5SMwLm59kOADDCnDBxhWjg8wtAQfYFBhPsCAMnyAYaX4AAOL8wGGlOEDDHsEVcnxAYSk+EAZhc/EKFzWY51Ms2GqDRXrnNao7UxP2pM09JewErUxMelK1JpOEtN7P0HfttTdyeVGYZmdOrl8iS1UfEy2+N6U+m2Y8yMBZsVdin3liseb64/X7t+2nr1ffHf/cm6Dm488ofoibwVG6z+s/vHWqQrWT1Swvubm0sH6mgRnCInmYL1R5gN9xgjVTzE7lk6kV4+ky0h5JpvUQ/WY/sGkhyWin33PIsQ/gA63aFJfrvNFQGZ3flMnmin85oF98iZd/wd+RMJqtcApT8YY2pJP/TSguZVqndFhKQuqFI8rBe9WTuK54Ccb8s2vtT7xzySFLlwle6rDTjTQSXJ6j7C59DdCNFsF8JorVpCxjt2GztmTQAXvV3auBC868L7WdnzA05zQVL3Ac7ZwO+ReswYWSiJjib5FD1FPJnoq6jnc4uo6p2ITj3pGyFIDMEFRGoFSWZR8Yd+PBSjelpCULfewiaigxmaatYrG8aiez33rpVkM72QsarMe2tec3D04FuPSJB6PIN1czygWKqiKIzdO6Frf/nHK72n33ePaJDcI90CIpC2KGvtoTozVBrA+OS5upvErmyNstI0u5WJR4rFQRsqo+fcbNbrOSFFk6T3gCwprPvC1UH4CVs6sOwzyw4lv/EQFP1TwY8jgh6GVgx9MG5FZjm/Zw9Y4kzeai0mMG/swptP2q7/gzhPcKCsdj+NRpVWrB7n8a3ufxt0dIhEPcDy2z7bjZ/VwAT4bwNGtCh38a7XsTDR0wBQcfSRMMdFj3X2pQgf9LC4rX4q1uEMpBayVWjeOgEujTCZlMo1tMhmsox2jmkx687bqmdlMkEcljCZeCwk1L2UiCdhDoAtlDilzqNBJ52sP4WCGMoiGWN6TW0SsnbKKRVSuja5MImUSjWQSWdbJTSJWvfAxTCJSb0hm03CER2TjK/bdqlhoN5HyEnX/abfA1lEcenGCj9tJmWDnME29PcITAyt3KVPxuZqK5pmbivXi+8pU7G15T24qsspytRRIUYW3lbk4pLm4rJiL/BnXS/xi/xnXzQHmYe1Fkr3La4W1lLfgMVDaImel45XP1F472tDLZzL2vsOzkKgq9Zvb6z+fuxnc37SqKe11SlN/50FKHUcAtUmfLAz8nevvuDFh3/93XtML0LPj0s2Cilr5AhT5VpF3byvOH2Au85P6EjM6GPsj4xmJI7W64qsLLTc1ebKs4WaxA2MHSsL0Mo3SwkVNZh5Ez2J0BXBZYpduRJaR0/UKeW3y+IcTB36SiqVRHN1rUUoaOPUO9x6CCpz/ewPnS9HAecNJ/aEi5wYr9UpFzntaX5N1Jd+oJ1arYpo6tkZXAjhIMXSalRag3LJTuCt4dlEibndEP0VUa6SuRuhGOPoh35VweEO+K4mgg3xnJSNl7P7KBeeGnFJx71S+M2xHj9jVaBM5nlSkTMnhexP3v4W78pNxhgQPYY+hVg79DK5WSl2N0M3waoV0NbxaIV2NoVZIZyOpFXZ/Q0vDw5SOoFZIZ8OrlVpXo03k4GqF9DSKDPbDdQwcrCpZtoaAjE5f1aCcLVX/4vmEScwZZwGM2VgFMAyzFiUZs47thKpiS2radtSx1S4WS1K1NoecWfOJdBnbSoXZzrq2rWlLdGFb9otsAuGuYntckMx6gqu9nM3Kq71YGOOtdtsNXoMvNgIVLlk8w7eD4rQ+rbgasKkEcR1iVpwbaYJYWMcCzBclANEqx+BrHEUp/TqQ8nfvIhfGEK//Hw==7Z1bc9o6F4Z/TWb2d1GNzpIvm6THJD03bXrDEDDBDeDUQE6//pPAJj4IG4itqI07s3eLcSBa8qO11istaY8cjG/fRN2r4UnY90d7GPZv98jhHsaIEqr+0lfulleEIMsLF1HQj296uPA1uPfjizC+Og/6/jRz4ywMR7PgKnuxF04mfm+WudaNovAme9sgHGW/9ap74RcufO11R8WrP4L+bLi8SgiED2+89YOLYfzV6i1v+c64m9wd3zoddvvhTeoSebVHDqIwnC3/Nb498Efaeolhlj/3es27q98s8iezTX7gPeHvXv3ov+sMh29+BR1yfC2iF/GnXHdH87jFp340C5QB1NVvke+rv467d+F8FjdidpeYZnoTjEfdiXq1P511o1nceeq3IPvDMAruw8lMfQw5ROpCbxiM+vEHkcOZ+uDkRerexfeRQ/0BkT8N7rvno+R1T98QTPzo292VH3+CujxQl+PvRcqg+0WbJA1UrfJvU5diG73xw7E/i+7ULcm7LO6v+IlFJH5989D/lAq+vDhM9T2lyYMXP3QXqw9/6Bb1j7hntuglXOilPcxH2njn6h8X+h+D8bTTD7oXnfD8twYhfl993eqWQg/eDIOZ//Wq29OvbxTAujdm46TPisYsfYQ2tjBmkgPOFUPxH5YxOC3aGyW4pc2d9Evt1iYFa78++bo07iAY+dP/9sjL/606IErMqx5Y/789rH4ahgP9e/Vm8wVGix/SXzrRA6H6GD2I6Wf7f670iEQCIJbtBoQN/SAh4J7hyW+qK6jhwc+ZzO+rATt+6Y/Ow5tXDxf2FxfUG9fJoJYxZxTOJ32/nwxR8+h68UKPN9NwHvX8T34UqIb4ke6SYHIRv6lGuwt/tubN9FjI9a8w6adebdeDy9+iemBY/kLVj7S2VenzEPmj7iy4zjq/2nuVlQHmj/qbEjafBH/m/uKTokADNXWGKDVkUYDoaoiDpBouhkDiQazAxVu4aoGLOQWXaHu1ll6Vdfdq/KOfwkC1YzVQvBDcoxgwj6DlQIEyA4WXgz828vIzck/K6pfa/eGR60fm8/lg4EelQ/PivruuelgwS43mzgzKhAgOBHkYlWn1oMwRYDYHZa/FtxZ8EwHBAr/Cc4bfpNWpx2cBYvc2KCNXf+x0oVncqlt1suIIsJ5ggEtRjSkkANpMTFBROGk5NWQc1Zxie5yqLNcVTouKTk5jQM54TSqywsBKm03zh2wKNKio0LTw7QQftQafR9bDh6Rl+oqyEkj/cYU8BGVWi3YAvaJ206K3E3rcGnrcJfSKolPO8U2ccXxohZE7+LXqTjl+SWBVzZ89fQeT9fmhdf5KFB7NnyvsUanGrCx8XhE+yYrs4cbYa6WZCvbohuxhe9qMS+zhojjzl4SdBvTs+j3cyi0V7PFN2bOntzjFXoXg4gx7hZjz6dlr1ZYK9uSm7NmTW4hgwFuxh7OPlLDMXlFuWUwMdoLylR7p6cTiLTmt1HCHfrNz3Y1GwXTmTFKJs3gTvuFqN97Y2sJW0akLb3uSDhFyrWtdPVK28C5KOsu1Aim+3WAP8Wr4ZEOu1T/2zujP05Ozw97x9xffe78ImhpWX7foGVZWpckz2tFaTMsopE8wh1jW6JJVlO7MISJBJcDZ5TZGNRV6xuU2dRB493kyODkc3U1G8mg+OOtdvqbnLYHbE2i0ozUCCaMMSEispZNlzTUrOa5Ap4JGnQRsAB0HDFuErk0o64HOWjqJpScAZJI/KXTFNDLv8NyZO8QMYkA3YU8Cz1BL1hh77QTiir2yqKqSPWvThxhTpEIn/LQOrzhtuFBXKhScQpVickHXbe7pqt1RGC0+jv+Zh8sbFmWBg0H6UkbwUaBnvlI1Z/lp2W9IFz4afr2l5qvaPF38GlHkT6/CSV8/dLrCWN3WHeuhYnI+1X+FPfUsqyestyjk08VH2fdnw8X62aQOyZVRCJFNZnKwBwzzqPkHrLYRqJ1GrWcEsrfCHRMpgOC5IahBGbm0vX+BzsSot8HqBdGQ1GS2Xpvp1oSdtVQXcc4BRIibxCbr9BVT3n531o3LwjR+e/gg9393gORsEyCbTIS/y5PB7dGbiwtJPow/f5nuo4sfrfpUkQgbZl6MdrSGJBRCIUmhzDxLzcXiZa0tK9J0R/klUOj0JascGDNhDIE0lHA1Bl+rQtUDnzUVCqpsBhAqc1spNOcIy5q7ZhGfM9gxjoCXODOXsGuXG9SDna3FBtxjhAOufJ5xHZ9l+krKRxLf544ITIQaHCTFq/0GntYL/gx57+w38o5OPnReBPPh4HDQLkFI4VgWbKVxNNrRVgjKJVePCCM4G4I2yGFZc/P7DMSCTHj+2xkGoWTAy8efhuTPQ6v5mrrBwzdvv30V3cHgy5/9b9cvP0+9Y9GCVwGeoZjEaMd/F7yy5v6V4adx8qE5f2e0X5v1lWNnqCMx2tFW1ucIdsWsz1V/J4gElDzEnNnNc4xVlB4QDa25+8RHbNq7uPx2z079e3JzT4LW81UuOIdFBo2GtOb6PKTcDEE0p7ygxhgsa65xbyuHBE8pCRCkWnkxbaRbB3PkxRWeT2fD9zz6NH4z5zN0+71lbgfmjIa0F25SBAGWXHjLP9nnCTaGXlmr3V7vSjwPu0deG3DWRJ61iFNQhgEiFC/BywaetslbE3gunJ47Sqcaq5BGLwk6c2sVLDJ49JF8Pfz6E0ZHnR+f5q/3v3x614qcKQbLIqs0gkY7WnN+nHK9Uy8SlhEsa3Xq6dH0uYIe8SABMnmiS9I8LNVtFqFrHd8KurKYqhI6a37PKehKp9ndYc8UcRrYs+rt2hn2cvAMMwtGO1qbYXcKvOIMu0veji4mDPC6QNOAHoGNub1vgh3+OBZvYWc4EG8P7v68ujhsC6we6CubOU7TZ7SjrQIrLiDBgLI1QktzRf1lrTbVOLiCIOaMAQLRmlM0iCgyqH7AIxYZbEuM6mHQWolROYSkuQXWpc1OPT+T+bjjj/yxsn9pxaNqOgzVJZg6pqwfzKPJ4iTAaXd85dQpZYIhoDD0kj/Z0MOEMhLQVC1Yx0Eb5r5otZuaWLYm3gioT7KDNGY5OwFtneWietNTfT7rwFUZcaaS99/g2uNajl3PNQXJoR6Zs64ESJYLZNw0SYivn+5WJKqJbnsqEVQeADNsnB2xTndRJorj5Zk+J9oRHAniEsitImbOQdI2KxFze65HXSBaU42YBtGDLFGNskucrZO4dhfIfjB2qzyfYOX/PJqVjkwQSmVfm9JRe7pHXRBaE49UmMsA5sgNb7hOPfpvoiF0B0DiMSD5RgAKm7pRe8RHTQBaO+GDK/AIIEg6kWwaTvhYJJvuEcgQB8x7iEizK3tNLDZYH8U6H+969+LLq/37H4P7y5fdz/SknUfZfr8aox2tuUJMsV6wumbZXHPzKGWtzi2bO+uOR6/1kQGn3SRDzKs9evMavX8NdGTvurU7661kqMXedOmt6WBuNzpnRh0kIQf5wyhMK5X03pmyONawGsaa3tfb95+PfswjJL9/EAff8P67r+36wB2OQDAaElsabJjHPKH8Ebee/JY1O/X86OlaqP+pXyWrFJ6eQJzbD9J0AkIylVO3lzdartV/ayLPlv7LJGEEcEaw5YC7rNWpx0efF/QsDxYiGxxuYj5ZqCm2W0m5JrZtScpMwMVEhWdciGib7aKgvDw1LPIvFHd+5PefHeMMusZ4m6XXxLitNJ1RLDzAMXaC8WKarhcbV/hv/aE6vx13bzvdW9+Ztcmc7khnPQss0Nz/dPX7JpLTdx9/81F4encO28x2exXNaEdriS3yCAKYedjyauSyVueLT11NbiGVm2y73tBeJ2eju3HnN/wVnHnTD4y+3z/3W2VpB/6MdrTFHxX6CDrPY2ueo/rBK2vuer/oCHFoo33VOW9s6mjmTV9+3OdfboYvRx3282x6eXbaQrdDUGo0pDXqCIIYoNweX4STpqAra23qsbnSX+VH+jQDvdw3zijjA+PzoeniZh2XzsKtkk83UBYbKMPIJA3r9S81RK+Tzg9y+5Fdv+Y/X51ei/uzt+xtC/IDyGUn4qU5NtrRFsdqpPcwkMoHGKszm6tkLWv1+jPL3CBP17SuDr0trSEHvKElwSdve1/wn6s3dzjsX1x+5GHn80ELX4UXNYSuRjtagw8LXZgpPGbcbbzB3frKmp16fB6E206yNGFqWoAR55WpJQ7zSfBn7u89LGlwRvOhSA14JLeWGGGD7yQQeA0VzuFfB7P907uX43P6+kvn6FX08/JLi+/2vtNoR2v4QkEQEBLH+CaFa4lHaE6ZLWu2cf8VV+DTVUgA0VWVm1e9y3uDTtRoxnZ9Qz0U2lregCSXVCU0AjpB4Zrd/1YCLIYTZ2Dkevhao1fbIRB+H5++wh+jHiW97p/Dk/fBXbvb9C5ikNGQthwh4kgQQClfUy2ZXwVaH4JlzV5z4ILyhXAcRn6xjNwNKr0NVgVJ05RkDTheBr+C/fBX98vp5T759eX2zfj3sHWIFQ7RkFUa7WjNIepN7oC3mo+0txF1WbPd3hZQb5EE1k3dWjpv9tNFh59P+79fHb2fk/OzIxS9a8/e20HSMdrR1oI8TwgKJLIm5JQ1dh1ysftzgzxKOAHYq5ZjtExtqDCpQ4052H8x/vGhN74/vLwYnb6C7OQ1NG0pdZpAhOG3yNfq1nH3LpzPCrac3gTjUXfi52jQGcD+MIyC+3Ay6yaW7Q2DUT/+IHI4Ux+cvEjdu/i+JV+RPw3utaQWv+7pG4KJH33T5VHLT9hbFj3F36tSIlMHbl8NhHOrGQU1DJEeNBQA0+b6qZguJIVjH89/+71ZXDYGkzqxNbsHZeb6ljOBptqux1JT/qxt3hWQc+WwKBPZyXxTh+CGRExzU4rRd6aOb5feWM685srwquvtCtWAxPzjS8W625vNF2gvvq2GuaaaeppilX4zhFeiWbbDETH1uGnWV9axZNHcqGeQIpT2ZjpMKR2k0nFKKT71BSqP61mznGWoyq0COirgWqy03ZrxWThbIJuaeFphvJp4cgdlhD0BPLwBwMIywM8gzbAFcO1p/qY9O74gf97CX/vRpOeffYZ3N/h6/hy01Ed2rCGDNFrSmpgKJfQAwxLHPj+bS/LmxNSyZmceoM1jNrRmNHdkQFYZDGAoNyDrY1eKW20aJVdUx4hsNHsbUT1wW/ZcVmJrTXWFHqIxttnnSRQdd8PMFoO2dG1kWQ1mKpBKLdyBwUSbeujH2ZFDERXM2poYzi1D3IyuaIrdNpiqy+faUm1dgrdCvHUEPEqZspeLnvMZ1Ddbos9WgTOCQmAA10W89hEs1jhvE/NOYhfpcNyrz4ORqVV4uYlPI8YeA55pFVAtJE8n0d3p6MN3eCD+vMbhcThmpM1dK0k2rMUzWtJe7goJA/yB5Gx5WIO5a1mzd+B4IUY6nrx60gPS28gDG+ZNG+S2jX/r4tbeqgXMdTGnGdtGHXBZux2PgREhGAixCYHmTUSaQ7ANgutC0FYQ7BFI13tO+wjuHgMvfOfEbd+JuFThbH7LCHPca5fcZ7Cf/cbklgV1leBaOwlRqj8xuRa1o9I2p56e627UGUy6460X/KksdnSw2jGb9Lu+HPQWvR2Fl37qHd6T/vmgSVqlRAB61UovN8W5NSx0Mtu6TU+3n6IxW9JWeupR5K33sRLbzU4NK+UW0zR/O61EQADxBrQ2VMRiNnablFb4Vb4prbaSUkkYjZPSJ/erxYT0X/CrSEEI+Gr3CZg76MEIbUO7gplDvaLZW2h3CoaxsAUtw9AIrW3viosSSLPVn3UxiaAoyLomEoUENsNdbBIEWhZ3cKDYs8SikAIBxh1gsShqaPep/qvDgTJf9qnJgUp8TvgOPb2VAsy2dKAqlWU2uSVFSeD5clu2Wq6SW4Js+VBIBcCEiKTo52npJUWhI7OccPsdMR0iOLFlQqz3sC6wYgkTlrXsomk2eVEaaKHdDVpiDVqvDFoPFhecNs1tcQ05eMQ0qkPQovyxDY5QW1x33VK7G7XMErWCqXgMU1IIkZ+C16JEmfGzE/WPv9rV5jc2MlNrmm9tlNpWZKqg1rDdmNmStkQmjjAEENHE18qn1odJUWwyVNw4ojAxzgGjDzlrdusVo9SkxkhRpLK5nLVdBFETkkmgZON4XwKQxMnUanZFue2UlRZFj9qmVgcDn/eMEzZ94Z1D2CS6enMpQjaYWuVAcIvA0nYtRIU4vDGw2BKwVHIKJEPCCKx9F5o0vIEp1qckFjE9T8M2QFaAxAR2kG0rzOtC1laJOeXqIYFch71PqwjTotBR33zOQPZ8M63nUoetjdLKJVeh7kaTr0mQaofWdvlSBa1JClaNq7WzuQlEwOOScidCYtPh3I+axWmMQl1bLlOTqvntxI0nhBozVFzLlllme7YlNrURae0kbaKPW6LriPQKVR1NM1lcU5PZqd6dUjfGBEA85xfd4LDViurikNkSi1QgSwGCpLD1ln0E2RqlqM5Jl6eMaDmXgOYVIwO4HgSmbZvrAde4SXkrGe2w5aTRktYkI8gZEEJinsOW88agLWtw/oylWTAb1bCvfW25JIWAiNz5SqbdXpkEXkNqrdF8rfJTF3m2lB+CdKEGfdgG/Gn5W3PG2Xl36ve7M4cQFMQDhGyAoLHIuwb+Di9e8oPTu/vriH0IoiGicjhp+duhqsVoSFv4CeX3EOFSiqUoQbLPE2zuRKWyZv9zq+n1hkablHk3V/liNHcrvW5f+GI0pCXhlSEChHw4MUM8La1r9zLac70SjTKx0WRIgyUtRou2yuv2M5dGQ1rSXZGkDHhYcCKoC0SuVV2dJ1LqPaL4NuVmDU5UmhtVHO6e+6lpONEYSw5NE+YTXRs71qc4hKrw8TiYbntYWrJJfEeLpTZ3/OLb9gLJBZaGTjAlgc2dk1YchXQUr0P4sg36n/bEo62tvjqJbOvDjhqz+7OdL+LF6KF0cKg+6qj2+OFRPZs8anlZarEjYSeY9INe7hTBHdkq/PBMBQ2LYzJm+v/hzaQ4bsL4+50hk5Idyczv4Vxf/z3bGaHayUxQsE/m8e0PdnR08AZ+fnt1PPH6Z6PL989X8Ny4Yw0Zm9GS9k4zwtaOHStrqCk60ivVoOFcSXWXvhGmDvBlxdvyG7wbbnmEmtrYcJ2Lo1avq/aY5jWM1sYOeraqaO1MW9vkPemifB5qCekn2dR9+4yFV5NmStbrSFiMZnu2amftoFlbZirWCD6WQCtRFuLlbPW4z/jD/hYPKjdwocjkQpsKi5/vDtKPSXjMpsSW2Ea5tJlbZtuwabSG7Up/nx+tUTcW72ppYhYupYy0zOgInpxuoEdgA56ENHYsOi4a+7lPZhDC1zi3VD9RZugnnJ/lq6+bivqCXsNtms6AhRmMxWpvy7MXq+dqm5m/jNWfevYCrzliuGr6wiStLk5NbGog2t7Um8xYmMah5mz9XFPtVTurwoRkAKjWRWvXzx7Xs8WUeHWO6CYTFmU0bTJJsZyUCBqblXj8OGekjxjoa25W4rnm3w3QV7vS9aj067lOBD+qY81JiaXCQSxgrvDB8qyE4XytxVidTb8cGUsJqx5LzcuOtgZOvYzCcJY2tmrn8CTs+/qO/wM= \ No newline at end of file diff --git a/diag_manager/docs_uml/Untitled Diagram.drawio b/diag_manager/docs_uml/Untitled Diagram.drawio new file mode 100644 index 0000000000..a4e56faf62 --- /dev/null +++ b/diag_manager/docs_uml/Untitled Diagram.drawio @@ -0,0 +1,141 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/diag_manager/docs_uml/classDiagramDiagObjects.drawio b/diag_manager/docs_uml/classDiagramDiagObjects.drawio new file mode 100644 index 0000000000..7d9233fcd7 --- /dev/null +++ b/diag_manager/docs_uml/classDiagramDiagObjects.drawio @@ -0,0 +1,277 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/diag_manager/docs_uml/diag_manager_end.drawio b/diag_manager/docs_uml/diag_manager_end.drawio new file mode 100644 index 0000000000..7ccb47c159 --- /dev/null +++ b/diag_manager/docs_uml/diag_manager_end.drawio @@ -0,0 +1,175 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/diag_manager/docs_uml/diag_manager_init.drawio b/diag_manager/docs_uml/diag_manager_init.drawio new file mode 100644 index 0000000000..dc8b20961a --- /dev/null +++ b/diag_manager/docs_uml/diag_manager_init.drawio @@ -0,0 +1 @@ +UzV2zq1wL0osyPDNT0nNUTV2VTV2LsrPL4GwciucU3NyVI0MMlNUjV1UjYwMgFjVyA2HrCFY1qAgsSg1rwSLBiADYTaQg2Y1AA== \ No newline at end of file diff --git a/diag_manager/docs_uml/fms_diag_object_relationships.drawio b/diag_manager/docs_uml/fms_diag_object_relationships.drawio new file mode 100644 index 0000000000..c431fb9f9d --- /dev/null +++ b/diag_manager/docs_uml/fms_diag_object_relationships.drawio @@ -0,0 +1,277 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 new file mode 100644 index 0000000000..8f22f7d2db --- /dev/null +++ b/diag_manager/fms_diag_axis_object.F90 @@ -0,0 +1,1380 @@ +!*********************************************************************** +!* 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_axis_object_mod fms_diag_axis_object_mod +!> @ingroup diag_manager +!! @brief fms_diag_axis_object_mod stores the diag axis object, a diag domain +!! object, and a subaxis object. + +!> @file +!> @brief File for @ref diag_axis_object_mod + +!> @addtogroup fms_diag_axis_object_mod +!> @{ +module fms_diag_axis_object_mod +#ifdef use_yaml + use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, & + & mpp_get_global_domain, NORTH, EAST, mpp_get_tile_id, & + & mpp_get_ntile_count, mpp_get_io_domain + use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind + use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, & + direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, & + MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype, pack_size_str, & + get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,& + get_base_second + use mpp_mod, only: FATAL, mpp_error, uppercase, mpp_pe, mpp_root_pe, stdout + use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, & + & register_axis, register_field, register_variable_attribute, write_data + use fms_diag_yaml_mod, only: subRegion_type, diag_yaml + use diag_grid_mod, only: get_local_indices_cubesphere => get_local_indexes + use axis_utils2_mod, only: nearest_index + implicit none + + PRIVATE + + public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, & + & get_domain_and_domain_type, diagDomain_t, & + & DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T + public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name, define_diurnal_axis, & + & fmsDiagDiurnalAxis_type, create_new_z_subaxis + + !> @} + + !> @brief Type to hold the domain info for an axis + !! This type was created to avoid having to send in "Domain", "Domain2", "DomainUG" as arguments into subroutines + !! and instead only 1 class(diagDomain_t) argument can be send + !> @ingroup diag_axis_object_mod + type diagDomain_t + contains + procedure :: set => set_axis_domain + procedure :: length => get_length + procedure :: get_ntiles + end type diagDomain_t + + !> @brief Type to hold the 1d domain + type, extends(diagDomain_t) :: diagDomain1d_t + type(domain1d) :: Domain !< 1d Domain of the axis + end type + + !> @brief Type to hold the 2d domain + type, extends(diagDomain_t) :: diagDomain2d_t + type(domain2d) :: Domain2 !< 2d Domain of an "X" or "Y" axis + end type + + !> @brief Type to hold the unstructured domain + type, extends(diagDomain_t) :: diagDomainUg_t + type(domainUG) :: DomainUG !< Domain of "U" axis + end type + + !> @brief Type to hold the diag_axis (either subaxis or a full axis) + !> @ingroup diag_axis_object_mod + type :: fmsDiagAxisContainer_type + class(fmsDiagAxis_type), allocatable :: axis + end type + + !> @brief Type to hold the diagnostic axis description. + !> @ingroup diag_axis_object_mod + TYPE fmsDiagAxis_type + INTEGER , private :: axis_id !< ID of the axis + + contains + procedure :: get_parent_axis_id + procedure :: get_subaxes_id + procedure :: get_axis_name + procedure :: is_z_axis + procedure :: write_axis_metadata + procedure :: write_axis_data + procedure :: add_structured_axis_ids + procedure :: get_structured_axis + procedure :: is_unstructured_grid + procedure :: get_edges_id + END TYPE fmsDiagAxis_type + + !> @brief Type to hold the subaxis + !> @ingroup diag_axis_object_mod + TYPE, extends(fmsDiagAxis_type) :: fmsDiagSubAxis_type + CHARACTER(len=:), ALLOCATABLE , private :: subaxis_name !< Name of the subaxis + INTEGER , private :: starting_index !< Starting index of the subaxis relative to the + !! parent axis + INTEGER , private :: ending_index !< Ending index of the subaxis relative to the + !! parent axis + INTEGER , private :: parent_axis_id !< Id of the parent_axis + INTEGER , private :: compute_idx(2) !< Starting and ending index of the compute domain + real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis + contains + procedure :: fill_subaxis + procedure :: axis_length + procedure :: get_starting_index + procedure :: get_ending_index + procedure :: get_compute_indices + END TYPE fmsDiagSubAxis_type + + !> @brief Type to hold the diurnal axis + !> @ingroup diag_axis_object_mod + TYPE, extends(fmsDiagAxis_type) :: fmsDiagDiurnalAxis_type + INTEGER , private :: ndiurnal_samples !< The number of diurnal samples + CHARACTER(len=:), ALLOCATABLE, private :: axis_name !< The diurnal axis name + CHARACTER(len=:), ALLOCATABLE, private :: long_name !< The longname of the diurnal axis + CHARACTER(len=:), ALLOCATABLE, private :: units !< The units + INTEGER , private :: edges_id !< The id of the diurnal edges + CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< The name of the edges axis + CLASS(*), ALLOCATABLE, private :: diurnal_data(:) !< The diurnal data + + contains + procedure :: get_diurnal_axis_samples + procedure :: write_diurnal_metadata + END TYPE fmsDiagDiurnalAxis_type + + !> @brief Type to hold the diagnostic axis description. + !> @ingroup diag_axis_object_mod + TYPE, extends(fmsDiagAxis_type) :: fmsDiagFullAxis_type + CHARACTER(len=:), ALLOCATABLE, private :: axis_name !< Name of the axis + CHARACTER(len=:), ALLOCATABLE, private :: units !< Units of the axis + CHARACTER(len=:), ALLOCATABLE, private :: long_name !< Long_name attribute of the axis + CHARACTER(len=1) , private :: cart_name !< Cartesian name "X", "Y", "Z", "T", "U", "N" + CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis + CHARACTER(len=:), ALLOCATABLE, private :: type_of_data !< The type of the axis_data ("float" or "double") + !< TO DO this can be a dlinked to avoid having limits + integer , private :: subaxis(MAX_SUBAXES) !< Array of subaxis + integer , private :: nsubaxis !< Number of subaxis + class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain + INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", "TWO_D_DOMAIN", + !! or "UG_DOMAIN") + INTEGER , private :: length !< Global axis length + INTEGER , private :: direction !< Direction of the axis 0, 1, -1 + INTEGER, ALLOCATABLE, private :: edges_id !< Axis ID for the edges axis + !! This axis will be written to the file + CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< Name for the previously defined "edges axis" + !! This will be written as an attribute + CHARACTER(len=:), ALLOCATABLE, private :: aux !< Auxiliary name, can only be geolon_t + !! or geolat_t + CHARACTER(len=128) , private :: req !< Required field names. + INTEGER , private :: tile_count !< The number of tiles + TYPE(fmsDiagAttribute_type),allocatable , private :: attributes(:) !< Array to hold user definable attributes + INTEGER , private :: num_attributes !< Number of defined attibutes + INTEGER , private :: domain_position !< The position in the doman (NORTH, EAST or CENTER) + integer, allocatable , private :: structured_ids(:) !< If the axis is in the unstructured grid, + !! this is the axis ids of the structured axis + + contains + + PROCEDURE :: add_axis_attribute + PROCEDURE :: register => register_diag_axis_obj + PROCEDURE :: axis_length => get_axis_length + PROCEDURE :: set_edges + PROCEDURE :: set_axis_id + PROCEDURE :: get_compute_domain + PROCEDURE :: get_indices + PROCEDURE :: get_global_io_domain + PROCEDURE :: get_aux + PROCEDURE :: has_aux + ! TO DO: + ! Get/has/is subroutines as needed + END TYPE fmsDiagFullAxis_type + + !> @addtogroup fms_diag_yaml_mod + !> @{ + contains + + !!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!! + !> @brief Initialize the axis + subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name, long_name, direction,& + & set_name, Domain, Domain2, DomainU, aux, req, tile_count, domain_position, axis_length ) + class(fmsDiagFullAxis_type),INTENT(inout):: this !< Diag_axis obj + CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis + class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values + CHARACTER(len=*), INTENT(in) :: units !< Units for the axis + CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N") + CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. + CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis + INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis + TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain + TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain + TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain + CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t + !! or geolat_t + CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names. + INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles + INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST" + integer, intent(in), optional :: axis_length !< The length of the axis size(axis_data(:)) + + this%axis_name = trim(axis_name) + this%units = trim(units) + this%cart_name = uppercase(cart_name) + call check_if_valid_cart_name(this%cart_name) + + if (present(long_name)) this%long_name = trim(long_name) + + select type (axis_data) + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: this%axis_data(axis_length)) + this%axis_data = axis_data + this%length = axis_length + this%type_of_data = "double" !< This is what fms2_io expects in the register_field call + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%axis_data(axis_length)) + this%axis_data = axis_data + this%length = axis_length + this%type_of_data = "float" !< This is what fms2_io expects in the register_field call + class default + call mpp_error(FATAL, "The axis_data in your diag_axis_init call is not a supported type. & + & Currently only r4 and r8 data is supported.") + end select + + this%type_of_domain = NO_DOMAIN + if (present(Domain)) then + if (present(Domain2) .or. present(DomainU)) call mpp_error(FATAL, & + "The presence of Domain with any other domain type is prohibited. "//& + "Check you diag_axis_init call for axis_name:"//trim(axis_name)) + allocate(diagDomain1d_t :: this%axis_domain) + call this%axis_domain%set(Domain=Domain) + else if (present(Domain2)) then + if (present(DomainU)) call mpp_error(FATAL, & + "The presence of Domain2 with any other domain type is prohibited. "//& + "Check you diag_axis_init call for axis_name:"//trim(axis_name)) + allocate(diagDomain2d_t :: this%axis_domain) + call this%axis_domain%set(Domain2=Domain2) + this%type_of_domain = TWO_D_DOMAIN + else if (present(DomainU)) then + allocate(diagDomainUg_t :: this%axis_domain) + call this%axis_domain%set(DomainU=DomainU) + this%type_of_domain = UG_DOMAIN + endif + + this%tile_count = 1 + if (present(tile_count)) this%tile_count = tile_count + + this%domain_position = CENTER + if (present(domain_position)) this%domain_position = domain_position + call check_if_valid_domain_position(this%domain_position) + + this%direction = 0 + if (present(direction)) this%direction = direction + call check_if_valid_direction(this%direction) + + if (present(aux)) this%aux = trim(aux) + if (present(req)) this%req = trim(req) + + this%nsubaxis = 0 + this%num_attributes = 0 + end subroutine register_diag_axis_obj + + !> @brief Add an attribute to an axis + subroutine add_axis_attribute(this, att_name, att_value) + class(fmsDiagFullAxis_type),INTENT(INOUT) :: this !< diag_axis obj + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + integer :: j !< obj%num_attributes (for less typing) + + if (.not. allocated(this%attributes)) & + allocate(this%attributes(max_axis_attributes)) + + this%num_attributes = this%num_attributes + 1 + + j = this%num_attributes + call this%attributes(j)%add(att_name, att_value) + end subroutine add_axis_attribute + + !> @brief Write the axis meta data to an open fileobj + subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis) + class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj + class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write the data to + logical, INTENT(IN) :: edges_in_file !< .True. if the edges to this axis are + !! already in the file + class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< If the axis is a subaxis, axis object + !! for the parent axis (this will be used + !! to get some of the metadata info) + + character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist + character(len=:), pointer :: axis_name !< Name of the axis + integer :: axis_length !< Size of the axis + integer :: i !< For do loops + type(fmsDiagFullAxis_type), pointer :: diag_axis !< Local pointer to the diag_axis + + integer :: type_of_domain !< The type of domain the current axis is in + logical :: is_subaxis !< .true. if the axis is a subaxis + + is_subaxis = .false. + + select type(this) + type is (fmsDiagFullAxis_type) + axis_name => this%axis_name + axis_length = this%length + diag_axis => this + type_of_domain = this%type_of_domain + type is (fmsDiagSubAxis_type) + is_subaxis = .true. + axis_name => this%subaxis_name + axis_length = this%ending_index - this%starting_index + 1 + !< Get all the other information from the parent axis (i.e the cart_name, units, etc) + if (present(parent_axis)) then + select type(parent_axis) + type is (fmsDiagFullAxis_type) + diag_axis => parent_axis + end select + endif + type_of_domain = NO_DOMAIN !< All subaxes are treated as non-domain decomposed (each rank writes it own file) + type is (fmsDiagDiurnalAxis_type) + call this%write_diurnal_metadata(fms2io_fileobj) + return + end select + + !< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type + select type (fms2io_fileobj) + !< The register_field calls need to be inside the select type block so that it can go inside the correct + !! register_field interface + type is (FmsNetcdfFile_t) + !< Here the axis is not domain decomposed (i.e z_axis) + call register_axis(fms2io_fileobj, axis_name, axis_length) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + type is (FmsNetcdfDomainFile_t) + select case (type_of_domain) + case (NO_DOMAIN) + !< Here the fms2io_fileobj is domain decomposed, but the axis is not + !! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis) + call register_axis(fms2io_fileobj, axis_name, axis_length) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + case (TWO_D_DOMAIN) + !< Here the axis is domain decomposed + call register_axis(fms2io_fileobj, axis_name, diag_axis%cart_name, domain_position=diag_axis%domain_position) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + end select + type is (FmsNetcdfUnstructuredDomainFile_t) + select case (type_of_domain) + case (UG_DOMAIN) + !< Here the axis is in a unstructured domain + call register_axis(fms2io_fileobj, axis_name) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + case default + !< Here the fms2io_fileobj is in the unstructured domain, but the axis is not + !< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis) + call register_axis(fms2io_fileobj, axis_name, axis_length) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + end select + end select + + !< Write its metadata + call register_variable_attribute(fms2io_fileobj, axis_name, "long_name", diag_axis%long_name, & + str_len=len_trim(diag_axis%long_name)) + + if (diag_axis%cart_name .NE. "N") & + call register_variable_attribute(fms2io_fileobj, axis_name, "axis", diag_axis%cart_name, str_len=1) + + if (trim(diag_axis%units) .NE. "none") & + call register_variable_attribute(fms2io_fileobj, axis_name, "units", diag_axis%units, & + str_len=len_trim(diag_axis%units)) + + select case (diag_axis%direction) + case (direction_up) + call register_variable_attribute(fms2io_fileobj, axis_name, "positive", "up", str_len=2) + case (direction_down) + call register_variable_attribute(fms2io_fileobj, axis_name, "positive", "down", str_len=4) + end select + + !< Ignore the edges attribute, if the edges are already in the file or if it is subaxis + if (.not. edges_in_file .and. allocated(diag_axis%edges_name) .and. .not. is_subaxis) then + call register_variable_attribute(fms2io_fileobj, axis_name, "edges", diag_axis%edges_name, & + str_len=len_trim(diag_axis%edges_name)) + endif + + if(allocated(diag_axis%attributes)) then + do i = 1, diag_axis%num_attributes + select type (att_value => diag_axis%attributes(i)%att_value) + type is (character(len=*)) + call register_variable_attribute(fms2io_fileobj, axis_name, diag_axis%attributes(i)%att_name, & + trim(att_value(1)), str_len=len_trim(att_value(1))) + class default + call register_variable_attribute(fms2io_fileobj, axis_name, diag_axis%attributes(i)%att_name, att_value) + end select + enddo + endif + + end subroutine write_axis_metadata + + !> @brief Write the axis data to an open fms2io_fileobj + subroutine write_axis_data(this, fms2io_fileobj, parent_axis) + class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj + class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write the data to + class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< The parent axis if this is a subaxis + + integer :: i !< Starting index of a sub_axis + integer :: j !< Ending index of a sub_axis + integer :: global_io_index(2)!< Global io domain starting and ending index + select type(this) + type is (fmsDiagFullAxis_type) + call this%get_global_io_domain(global_io_index) + call write_data(fms2io_fileobj, this%axis_name, this%axis_data(global_io_index(1):global_io_index(2))) + type is (fmsDiagSubAxis_type) + i = this%starting_index + j = this%ending_index + + if (present(parent_axis)) then + select type(parent_axis) + type is (fmsDiagFullAxis_type) + call write_data(fms2io_fileobj, this%subaxis_name, parent_axis%axis_data(i:j)) + end select + endif + type is (fmsDiagDiurnalAxis_type) + call write_data(fms2io_fileobj, this%axis_name, this%diurnal_data) + end select + end subroutine write_axis_data + + + !> @brief Defined a new diurnal axis + subroutine define_diurnal_axis(diag_axis, naxis, n_diurnal_samples, is_edges) + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Array of axis containers + integer, intent(inout) :: naxis !< Number of axis that have + !! been defined + integer, intent(in) :: n_diurnal_samples !< The number of diurnal samples + !! for the curent axis + logical, intent(in) :: is_edges !< Flag indicating if this is + !! an edge axis + + CHARACTER(32) :: axis_name !< name of the axis + CHARACTER(32) :: long_name !< long name of the axis + CHARACTER(32) :: edges_name !< name of the axis edge + CHARACTER(128) :: units !< units of the axis + real(kind=r8_kind), allocatable :: diurnal_data(:) !< Data for the axis + integer :: edges_id !< Id of the axis edge + integer :: i !< For do loops + + naxis = naxis + 1 + + axis_name = '' + edges_name = '' + if (is_edges) then + WRITE (axis_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples + long_name = "time of day edges" + allocate(diurnal_data(n_diurnal_samples + 1)) + diurnal_data(1) = 0.0 + edges_id = diag_null + do i = 1, n_diurnal_samples + diurnal_data(i+1) = 24.0* REAL(i)/n_diurnal_samples + enddo + else + WRITE (axis_name,'(a,i2.2)') 'time_of_day_', n_diurnal_samples + long_name = "time of day" + allocate(diurnal_data(n_diurnal_samples)) + edges_id = naxis -1 !< The diurnal edges is the last defined axis + do i = 1, n_diurnal_samples + diurnal_data(i) = 24.0*(REAL(i)-0.5)/n_diurnal_samples + enddo + WRITE (edges_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples + endif + + WRITE (units,11) 'hours', get_base_year(), get_base_month(), & + get_base_day(), get_base_hour(), get_base_minute(), get_base_second() +11 FORMAT(a,' since ',i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':',i2.2) + + allocate(fmsDiagDiurnalAxis_type :: diag_axis(naxis)%axis) + select type (diurnal_axis => diag_axis(naxis)%axis) + type is (fmsDiagDiurnalAxis_type) + diurnal_axis%axis_id = naxis + diurnal_axis%ndiurnal_samples = n_diurnal_samples + diurnal_axis%axis_name = trim(axis_name) + diurnal_axis%long_name = trim(long_name) + diurnal_axis%units = trim(units) + diurnal_axis%diurnal_data = diurnal_data + diurnal_axis%edges_id = edges_id + if (is_edges) & + WRITE (edges_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples + diurnal_axis%edges_name = trim(edges_name) + end select + end subroutine define_diurnal_axis + + !< @brief Determine if the axis is in the unstructured grid + !! @return .True. if the axis is in unstructured grid + pure logical function is_unstructured_grid(this) + class(fmsDiagAxis_type), target, INTENT(in) :: this !< diag_axis obj + + is_unstructured_grid = .false. + select type (this) + type is (fmsDiagFullAxis_type) + is_unstructured_grid = trim(this%cart_name) .eq. "U" + end select + end function is_unstructured_grid + + !< @brief Adds the structured axis ids to the axis object + subroutine add_structured_axis_ids(this, axis_ids) + class(fmsDiagAxis_type), target, INTENT(inout) :: this !< diag_axis obj + integer, intent(in) :: axis_ids(2) !< axis ids to add to the axis object + + select type (this) + type is (fmsDiagFullAxis_type) + allocate(this%structured_ids(2)) + this%structured_ids = axis_ids + end select + end subroutine add_structured_axis_ids + + !< @brief Get the structured axis ids from the axis object + !! @return the structured axis ids + pure function get_structured_axis(this) & + result(rslt) + class(fmsDiagAxis_type), target, INTENT(in) :: this !< diag_axis obj + integer :: rslt(2) + + rslt = diag_null + select type (this) + type is (fmsDiagFullAxis_type) + rslt = this%structured_ids + end select + end function get_structured_axis + + + !< @brief Get the edges_id of an axis_object + !! @return The edges_id of an axis object + pure integer function get_edges_id(this) + class(fmsDiagAxis_type), INTENT(in) :: this !< diag_axis obj + + get_edges_id = diag_null + select type (this) + type is (fmsDiagFullAxis_type) + if (allocated(this%edges_id)) get_edges_id = this%edges_id + end select + end function + + !> @brief Get the starting and ending indices of the global io domain of the axis + subroutine get_global_io_domain(this, global_io_index) + class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj + integer, intent(out) :: global_io_index(2) !< Global io domain starting and ending index + + type(domain2d), pointer :: io_domain !< pointer to the io domain + + global_io_index(1) = 1 + global_io_index(2) = this%length + + if (allocated(this%axis_domain)) then + select type(domain => this%axis_domain) + type is (diagDomain2d_t) + io_domain => mpp_get_io_domain(domain%domain2) + if (this%cart_name .eq. "X") then + call mpp_get_global_domain(io_domain, xbegin=global_io_index(1), xend=global_io_index(2), & + position=this%domain_position) + elseif (this%cart_name .eq. "Y") then + call mpp_get_global_domain(io_domain, ybegin=global_io_index(1), yend=global_io_index(2), & + position=this%domain_position) + endif + end select + endif + end subroutine get_global_io_domain + + !> @brief Get the length of the axis + !> @return axis length + function get_axis_length(this) & + result (axis_length) + class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj + integer :: axis_length + + !< If the axis is domain decomposed axis_length will be set to the length for the current PE: + if (allocated(this%axis_domain)) then + axis_length = this%axis_domain%length(this%cart_name, this%domain_position, this%length) + else + axis_length = this%length + endif + + end function + + + !> @brief Determine if an axis object has an auxiliary name + !! @return .true. if an axis object has an auxiliary name + pure function has_aux(this) & + result(rslt) + class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj + logical :: rslt + + rslt = .false. + if (allocated(this%aux)) rslt = trim(this%aux) .ne. "" + end function has_aux + + !> @brief Get the auxiliary name of an axis object + !! @return the auxiliary name of an axis object + pure function get_aux(this) & + result(rslt) + class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj + character(len=:), allocatable :: rslt + + rslt = this%aux + end function get_aux + + !> @brief Set the axis_id + subroutine set_axis_id(this, axis_id) + class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj + integer, intent(in) :: axis_id !< Axis_id + + this%axis_id = axis_id + + end subroutine set_axis_id + + !> @brief Set the name and ids of the edges + subroutine set_edges(this, edges_name, edges_id) + class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj + CHARACTER(len=*), intent(in) :: edges_name !< Name of the edges + integer, intent(in) :: edges_id !< Axis id of the edges + + !< Saving the name and the id of the edges axis because it will make it easier to use + !! downstream (i.e you need the edges name to write the attribute to the current axis, + !! and you need the edges id to add to the diag file object so that you can write the edges + !! to the file) + this%edges_name = edges_name + this%edges_id = edges_id + end subroutine set_edges + + !> @brief Determine if the subRegion is in the current PE. + !! If it is, determine the starting and ending indices of the current PE that belong to the subRegion + subroutine get_indices(this, compute_idx, corners_indices, starting_index, ending_index, need_to_define_axis) + class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj + integer, intent(in) :: compute_idx(:) !< Current PE's compute domain + class(*), intent(in) :: corners_indices(:) !< The indices of the corners of the subRegion + integer, intent(out) :: starting_index !< Starting index of the subRegion + !! for the current PE + integer, intent(out) :: ending_index !< Ending index of the subRegion + !! for the current PE + logical, intent(out) :: need_to_define_axis !< .true. if it is needed to define + !! an axis + + integer :: subregion_start !< Starting index of the subRegion + integer :: subregion_end !< Ending index of the subRegion + + !< Get the rectangular coordinates of the subRegion + !! If the subRegion is not rectangular, the points outside of the subRegion will be masked + !! out later + select type (corners_indices) + type is (integer(kind=i4_kind)) + subregion_start = minval(corners_indices) + subregion_end = maxval(corners_indices) + end select + + !< Initiliaze the output + need_to_define_axis = .false. + starting_index = diag_null + ending_index = diag_null + + !< If the compute domain of the current PE is outisde of the range of sub_axis, return + if (compute_idx(1) < subregion_start .and. compute_idx(2) < subregion_start) return + if (compute_idx(1) > subregion_end .and. compute_idx(2) > subregion_end) return + + need_to_define_axis = .true. + if (compute_idx(1) >= subregion_start .and. compute_idx(2) >= subregion_end) then + !< In this case all the point of the current PE are inside the range of the sub_axis + starting_index = compute_idx(1) + ending_index = compute_idx(2) + else if (compute_idx(1) >= subregion_start .and. compute_idx(2) <= subregion_end) then + !< In this case all the points of the current PE are valid up to the end point + starting_index = compute_idx(1) + ending_index = subregion_end + else if (compute_idx(1) <= subregion_start .and. compute_idx(2) <= subregion_end) then + !< In this case all the points of the current PE are valid starting with t subregion_start + starting_index = subregion_start + ending_index = compute_idx(2) + else if (compute_idx(1) <= subregion_start .and. compute_idx(2) >= subregion_end) then + !< In this case only the points in the current PE ar valid + starting_index = subregion_start + ending_index = subregion_end + endif + + end subroutine get_indices + + !< Get the compute domain of the axis + subroutine get_compute_domain(this, compute_idx, need_to_define_axis, tile_number) + class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj + integer, intent(inout) :: compute_idx(:) !< Compute domain of the axis + logical, intent(out) :: need_to_define_axis !< .true. if it needed to define the axis + integer, optional, intent(in) :: tile_number !< The tile number of the axis + + !< Initialize the output + need_to_define_axis = .false. + compute_idx = diag_null + + if (.not. allocated(this%axis_domain)) then + !< If the axis is not domain decomposed, use the whole axis as the compute domain + if (this%cart_name .eq. "X" .or. this%cart_name .eq. "Y") then + compute_idx(1) = 1 + compute_idx(2) = size(this%axis_data) + need_to_define_axis = .true. + endif + return + endif + + select type(domain => this%axis_domain) + type is (diagDomain2d_t) + if (present(tile_number)) then + !< If the the tile number is present and the current PE is not on the tile, then there is no need + !! to define the axis + if (any(mpp_get_tile_id(domain%Domain2) .ne. tile_number)) then + need_to_define_axis = .false. + return + endif + endif + + !< Get the compute domain for the current PE if it is an "X" or "Y" axis + select case (this%cart_name) + case ("X") + call mpp_get_compute_domain(domain%Domain2, xbegin=compute_idx(1), xend=compute_idx(2), & + & position=this%domain_position) + need_to_define_axis = .true. + case ("Y") + call mpp_get_compute_domain(domain%Domain2, ybegin=compute_idx(1), yend=compute_idx(2), & + & position=this%domain_position) + need_to_define_axis = .true. + end select + end select + + end subroutine get_compute_domain + + !!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!! + !> @brief Fills in the information needed to define a subaxis + subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, & + zbounds) + class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj + integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE + integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE + integer , intent(in) :: axis_id !< Axis id to assign to the subaxis + integer , intent(in) :: parent_id !< The id of the parent axis the subaxis belongs to + character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis + integer , intent(in) :: compute_idx(2) !< Starting and ending index of + !! the axis's compute domain + real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis + + this%axis_id = axis_id + this%starting_index = starting_index + this%ending_index = ending_index + this%parent_axis_id = parent_id + this%subaxis_name = trim(parent_axis_name)//"_sub01" + this%compute_idx = compute_idx + + if (present(zbounds)) then + allocate(this%zbounds(2)) + this%zbounds = zbounds + endif + end subroutine fill_subaxis + + !> @brief Get the axis length of a subaxis + !> @return the axis length + function axis_length(this) & + result(res) + class(fmsDiagSubAxis_type) , INTENT(IN) :: this !< diag_sub_axis obj + integer :: res + + res = this%ending_index - this%starting_index + 1 + end function + + !> @brief Accesses its member starting_index + !! @return a copy of the starting_index + function get_starting_index(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx !< Result to return + indx = this%starting_index + end function get_starting_index + + !> @brief Accesses its member ending_index + !! @return a copy of the ending_index + function get_ending_index(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx !< Result to return + indx = this%ending_index + end function get_ending_index + + !> @brief Accesses its member compute_indices + !! @return a copy of the ending_index + function get_compute_indices(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx(2) !< Result to return + indx = this%compute_idx + end function get_compute_indices + + !> @brief Get the ntiles in a domain + !> @return the number of tiles in a domain + function get_ntiles(this) & + result (ntiles) + class(diagDomain_t), INTENT(IN) :: this !< diag_axis obj + + integer :: ntiles + + select type (this) + type is (diagDomain2d_t) + ntiles = mpp_get_ntile_count(this%domain2) + end select + end function get_ntiles + + !> @brief Get the length of a 2D domain + !> @return Length of the 2D domain + function get_length(this, cart_axis, domain_position, global_length) & + result (length) + class(diagDomain_t), INTENT(IN) :: this !< diag_axis obj + character(len=*), INTENT(IN) :: cart_axis !< cart_axis of the axis + integer, INTENT(IN) :: domain_position !< Domain position (CENTER, NORTH, EAST) + integer, INTENT(IN) :: global_length !< global_length of the axis + + integer :: length + + select type (this) + type is(diagDomain2d_t) + if (trim(cart_axis) == "X") call mpp_get_compute_domain(this%Domain2, xsize=length, position=domain_position) + if (trim(cart_axis) == "Y") call mpp_get_compute_domain(this%Domain2, ysize=length, position=domain_position) + class default + !< If domain is 1D or UG, just set it to the global length + length = global_length + end select + end function get_length + + !!!!!!!!!!!!!!!!! FMS_DOMAIN PROCEDURES !!!!!!!!!!!!!!!!! + + !> @brief Set the axis domain + subroutine set_axis_domain(this, Domain, Domain2, DomainU) + class(diagDomain_t) :: this !< fms_domain obj + TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1d domain + TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2d domain + TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain + + select type(this) + type is (diagDomain1d_t) + this%Domain = Domain + type is (diagDomain2d_t) + this%Domain2 = Domain2 + type is (diagDomainUg_t) + this%DomainUG = DomainU + end select + end subroutine set_axis_domain + + !< @brief Allocates the array of axis/subaxis objects + !! @return true if there the aray of axis/subaxis objects is allocated + logical function fms_diag_axis_object_init(axis_array) + class(fmsDiagAxisContainer_type) , allocatable, intent(inout) :: axis_array(:) !< Array of diag_axis + + if (allocated(axis_array)) call mpp_error(FATAL, "The diag_axis containers is already allocated") + allocate(axis_array(max_axes)) + !axis_array%axis_id = DIAG_NULL + + fms_diag_axis_object_init = .true. + end function fms_diag_axis_object_init + + !< @brief Deallocates the array of axis/subaxis objects + !! @return false if the aray of axis/subaxis objects was allocated + logical function fms_diag_axis_object_end(axis_array) + class(fmsDiagAxisContainer_type) , allocatable, intent(inout) :: axis_array(:) !< Array of diag_axis + + if (allocated(axis_array)) deallocate(axis_array) + fms_diag_axis_object_end = .false. + + end function fms_diag_axis_object_end + + !< @brief Determine the axis name of an axis_object + !! @return The name of the axis + !! @note This function may be called from the field object (i.e. to determine the dimension names for io), + !! The field object only contains the parent axis ids, because the subregion is defined in a per file basis, + !! so the is_regional flag is needed so that the correct axis name can be used + pure function get_axis_name(this, is_regional) & + result(axis_name) + class(fmsDiagAxis_type), intent(in) :: this !< Axis object + logical, intent(in), optional :: is_regional !< Flag indicating if the axis is regional + + character(len=:), allocatable :: axis_name + + select type (this) + type is (fmsDiagFullAxis_type) + axis_name = this%axis_name + if (present(is_regional)) then + if (is_regional) then + if (this%cart_name .eq. "X" .or. this%cart_name .eq. "Y") axis_name = axis_name//"_sub01" + endif + endif + type is (fmsDiagSubAxis_type) + axis_name = this%subaxis_name + end select + end function get_axis_name + + !< @brief Determine if the axis is a Z axis by looking at the cartesian name + !! @return .True. if the axis is a Z axis + pure logical function is_z_axis(this) + class(fmsDiagAxis_type), intent(in) :: this !< Axis object + is_z_axis = .false. + select type (this) + type is (fmsDiagFullAxis_type) + if (this%cart_name .eq. "Z") is_z_axis = .true. + end select + end function + + !> @brief Check if a cart_name is valid and crashes if it isn't + subroutine check_if_valid_cart_name(cart_name) + character(len=*), intent(in) :: cart_name + + select case (cart_name) + case ("X", "Y", "Z", "T", "U", "N") + case default + call mpp_error(FATAL, "diag_axit_init: Invalid cart_name: "//cart_name//& + "The acceptable values are X, Y, Z, T, U, N.") + end select + end subroutine check_if_valid_cart_name + + !> @brief Check if a domain_position is valid and crashes if it isn't + subroutine check_if_valid_domain_position(domain_position) + integer, INTENT(IN) :: domain_position + + select case (domain_position) + case (CENTER, NORTH, EAST) + case default + call mpp_error(FATAL, "diag_axit_init: Invalid domain_positon. "& + "The acceptable values are NORTH, EAST, CENTER") + end select + end subroutine check_if_valid_domain_position + + !> @brief Check if a direction is valid and crashes if it isn't + subroutine check_if_valid_direction(direction) + integer, INTENT(IN) :: direction + + select case(direction) + case(-1, 0, 1) + case default + call mpp_error(FATAL, "diag_axit_init: Invalid direction. "& + "The acceptable values are-1 0 1") + end select + end subroutine check_if_valid_direction + + !> @brief Loop through a variable's axis_id to determine and return the domain type and domain to use + subroutine get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, var_name) + class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Array of diag_axis + integer, INTENT(IN) :: axis_id(:) !< Array of axis ids + integer, INTENT(OUT) :: domain_type !< fileobj_type to use + CLASS(diagDomain_t), POINTER, INTENT(OUT) :: domain !< Domain + character(len=*), INTENT(IN) :: var_name !< Name of the variable (for error messages) + + integer :: i !< For do loops + integer :: j !< axis_id(i) (for less typing) + + domain_type = NO_DOMAIN + domain => null() + + do i = 1, size(axis_id) + j = axis_id(i) + select type (axis => diag_axis(j)%axis) + type is (fmsDiagFullAxis_type) + !< Check that all the axis are in the same domain + if (domain_type .ne. axis%type_of_domain) then + !< If they are different domains, one of them can be NO_DOMAIN + !! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z) + if (domain_type .eq. NO_DOMAIN .or. axis%type_of_domain .eq. NO_DOMAIN ) then + !< Update the domain_type and domain, if needed + if ((axis%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 1) & + & .or. axis%type_of_domain .eq. UG_DOMAIN) then + domain_type = axis%type_of_domain + domain => axis%axis_domain + endif + else + call mpp_error(FATAL, "The variable:"//trim(var_name)//" has axis that are not in the same domain") + endif + endif + end select + enddo + end subroutine get_domain_and_domain_type + + !> @brief Define a subaxis based on the subRegion defined by the yaml + subroutine define_subaxis (diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe) + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object + integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids + integer, intent(inout) :: naxis !< Number of axis registered + type(subRegion_type), intent(in) :: subRegion !< The subRegion definition from + !! the yaml + logical, intent(in) :: is_cube_sphere !< .true. if this is a cubesphere + logical, intent(out) :: write_on_this_pe !< .true. if the subregion + !! is on this PE + + select case(subRegion%grid_type) + case (latlon_gridtype) + call define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe) + case (index_gridtype) + call define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe) + end select + end subroutine define_subaxis + + !> @brief Fill in the subaxis object for a subRegion defined by index + subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe) + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object + integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids + integer, intent(inout) :: naxis !< Number of axis registered + type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml + logical, intent(out) :: write_on_this_pe !< .true. if the subregion + !! is on this PE + integer :: i !< For do loops + integer :: compute_idx(2) + integer :: starting_index, ending_index + logical :: need_to_define_axis + integer :: lat_indices(2), lon_indices(2) + + + do i = 1, size(axis_ids) + select type (parent_axis => diag_axis(axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + !< Get the PEs compute domain + call parent_axis%get_compute_domain(compute_idx, need_to_define_axis, tile_number=subRegion%tile) + + !< If this is not a "X" or "Y" axis, go to the next axis + if (.not. need_to_define_axis) then + cycle + endif + + !< Determine if the PE's compute domain is inside the subRegion + !! If it is get the starting and ending indices for that PE + call parent_axis%get_indices(compute_idx, subRegion%corners(:,i), starting_index, ending_index, & + need_to_define_axis) + + !< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis + if (.not. need_to_define_axis) then + compute_idx = diag_null + call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & + diag_null, diag_null, compute_idx) + cycle + endif + + !< If it made it to this point, the current PE is in the subRegion! + write_on_this_pe = .true. + + call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & + starting_index, ending_index, compute_idx) + end select + enddo + + end subroutine define_subaxis_index + + !> @brief Fill in the subaxis object for a subRegion defined by lat lon + subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe) + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object + integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids + integer, intent(inout) :: naxis !< Number of axis registered + type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml + logical, intent(in) :: is_cube_sphere !< .true. if this is a cubesphere + logical, intent(out) :: write_on_this_pe !< .true. if the subregion + !! is on this PE + + real :: lat(2) !< Starting and ending lattiude of the subRegion + real :: lon(2) !< Starting and ending longitude or the subRegion + integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion + integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion + integer :: compute_idx(2) !< Compute domain of the current axis + integer :: starting_index(2) !< Starting index of the subRegion for the current PE for the "x" and "y" + !! direction + integer :: ending_index(2) !< Ending index of the subRegion for the current PE for the "x" and "y" direction + logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis for the "x" and "y" direction + integer :: i !< For do loops + integer :: parent_axis_ids(2) !< The axis id of the parent axis for the "x" and "y" direction + logical :: is_x_y_axis !< .true. if the axis is x or y + integer :: compute_idx_2(2, 2) !< Starting and ending indices of the compute domain for the "x" and "y" direction + + !< Get the rectangular coordinates of the subRegion + !! If the subRegion is not rectangular, the points outside of the subRegion will be masked + !! out later + select type (corners => subRegion%corners) + type is (real(kind=r4_kind)) + lon(1) = minval(corners(:,1)) + lon(2) = maxval(corners(:,1)) + lat(1) = minval(corners(:,2)) + lat(2) = maxval(corners(:,2)) + end select + + if_is_cube_sphere: if (is_cube_sphere) then + !< Get the starting and ending indices of the subregion in the cubesphere relative to the global domain + call get_local_indices_cubesphere(lat(1), lat(2), lon(1), lon(2),& + & lon_indices(1), lon_indices(2), lat_indices(1), lat_indices(2)) + loop_over_axis_ids: do i = 1, size(axis_ids) + select_axis_type: select type (parent_axis => diag_axis(axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + !< Get the PEs compute domain + call parent_axis%get_compute_domain(compute_idx, is_x_y_axis) + + !< If this is not a "X" or "Y" axis go to the next axis + if (.not. is_x_y_axis) cycle + + !< Determine if the PE's compute domain is inside the subRegion + !! If it is get the starting and ending indices for that PE + if (parent_axis%cart_name .eq. "X") then + call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), & + need_to_define_axis(1)) + parent_axis_ids(1) = axis_ids(i) + compute_idx_2(1,:) = compute_idx + else if (parent_axis%cart_name .eq. "Y") then + call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), & + need_to_define_axis(2)) + parent_axis_ids(2) = axis_ids(i) + compute_idx_2(2,:) = compute_idx + endif + end select select_axis_type + enddo loop_over_axis_ids + else if_is_cube_sphere + loop_over_axis_ids2: do i = 1, size(axis_ids) + select type (parent_axis => diag_axis(axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + !< Get the PEs compute domain + call parent_axis%get_compute_domain(compute_idx, is_x_y_axis) + + !< If this is not a "X" or "Y" axis go to the next axis + if (.not. is_x_y_axis) cycle + + !< Get the starting and ending indices of the subregion relative to the global grid + if (parent_axis%cart_name .eq. "X") then + select type(adata=>parent_axis%axis_data) + type is (real(kind=r8_kind)) + lon_indices(1) = nearest_index(real(lon(1), kind=r8_kind), adata) + lon_indices(2) = nearest_index(real(lon(2), kind=r8_kind), adata) + 1 + type is (real(kind=r4_kind)) + lon_indices(1) = nearest_index(real(lon(1), kind=r4_kind), adata) + lon_indices(2) = nearest_index(real(lon(2), kind=r4_kind), adata) + 1 + end select + call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), & + need_to_define_axis(1)) + parent_axis_ids(1) = axis_ids(i) + compute_idx_2(1,:) = compute_idx + else if (parent_axis%cart_name .eq. "Y") then + select type(adata=>parent_axis%axis_data) + type is (real(kind=r8_kind)) + lat_indices(1) = nearest_index(real(lat(1), kind=r8_kind), adata) + lat_indices(2) = nearest_index(real(lat(2), kind=r8_kind), adata) + 1 + type is (real(kind=r4_kind)) + lat_indices(1) = nearest_index(real(lat(1), kind=r4_kind), adata) + lat_indices(2) = nearest_index(real(lat(2), kind=r4_kind), adata) + 1 + end select + call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), & + need_to_define_axis(2)) + parent_axis_ids(2) = axis_ids(i) + compute_idx_2(2,:) = compute_idx + endif + end select + enddo loop_over_axis_ids2 + endif if_is_cube_sphere + + !< If the PE's compute is not inside the subRegion move to the next axis + if (any(.not. need_to_define_axis )) return + + !< If it made it to this point, the current PE is in the subRegion! + write_on_this_pe = .true. + + do i = 1, size(parent_axis_ids) + select type (parent_axis => diag_axis(parent_axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + call define_new_axis(diag_axis, parent_axis, naxis, parent_axis_ids(i), & + starting_index(i), ending_index(i), compute_idx_2(i,:)) + end select + enddo + + end subroutine define_subaxis_latlon + + !> @brief Creates a new subaxis and fills it will all the information it needs + subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, & + starting_index, ending_index, compute_idx, new_axis_id, zbounds) + + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object + class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis + integer, intent(inout) :: naxis !< The number of axis that + !! have been defined + integer, intent(in) :: parent_id !< Id of the parent axis + integer, intent(in) :: starting_index !< PE's Starting index + integer, intent(in) :: ending_index !< PE's Ending index + integer, intent(in) :: compute_idx(2) !< Starting and ending index of + !! the axis's compute domain + integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating + real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis + + naxis = naxis + 1 !< This is the axis id of the new axis! + + !< Add the axis_id of the new subaxis to the parent axis + parent_axis%nsubaxis = parent_axis%nsubaxis + 1 + parent_axis%subaxis(parent_axis%nsubaxis) = naxis + + !< Allocate the new axis as a subaxis and fill it + allocate(fmsDiagSubAxis_type :: diag_axis(naxis)%axis) + diag_axis(naxis)%axis%axis_id = naxis + if (present(new_axis_id)) new_axis_id = naxis + + select type (sub_axis => diag_axis(naxis)%axis) + type is (fmsDiagSubAxis_type) + call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, & + parent_axis%axis_name, compute_idx, zbounds) + end select + end subroutine define_new_axis + + !< @brief Determine the parent_axis_id of a subaxis + !! @return parent_axis_id if it is a subaxis and diag_null if is not a subaxis + pure function get_parent_axis_id(this) & + result(parent_axis_id) + + class(fmsDiagAxis_type), intent(in) :: this !< Axis Object + integer :: parent_axis_id + + select type (this) + type is (fmsDiagFullAxis_type) + parent_axis_id = diag_null + type is (fmsDiagSubAxis_type) + parent_axis_id = this%parent_axis_id + type is (fmsDiagDiurnalAxis_type) + parent_axis_id = diag_null + end select + + end function + + !< @brief Determine the most recent subaxis id in a diag_axis object + !! @return the most recent subaxis id in a diag_axis object + pure function get_subaxes_id(this) & + result(sub_axis_id) + + class(fmsDiagAxis_type), intent(in) :: this !< Axis Object + integer :: sub_axis_id + + sub_axis_id = this%axis_id + select type (this) + type is (fmsDiagFullAxis_type) + if (this%cart_name .ne. "Z") sub_axis_id = this%subaxis(this%nsubaxis) + end select + + end function + + !< @brief Parses the "compress" attribute to get the names of the two axis + !! @return the names of the structured axis + pure function parse_compress_att(compress_att) & + result(axis_names) + class(*), intent(in) :: compress_att(:) !< The compress attribute to parse + character(len=120) :: axis_names(2) + + integer :: ios !< Errorcode after parsing the compress attribute + + select type (compress_att) + type is (character(len=*)) + read(compress_att(1),*, iostat=ios) axis_names + if (ios .ne. 0) axis_names = "" + class default + axis_names = "" + end select + end function parse_compress_att + + !< @brief Determine the axis id of a axis + !! @return Axis id + pure function get_axis_id_from_name(axis_name, diag_axis, naxis) & + result(axis_id) + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of axis object + character(len=*), intent(in) :: axis_name !< Name of the axis + integer, intent(in) :: naxis !< Number of axis that have been registered + integer :: axis_id + + integer :: i !< For do loops + + axis_id = diag_null + do i = 1, naxis + select type(axis => diag_axis(i)%axis) + type is (fmsDiagFullAxis_type) + if (trim(axis%axis_name) .eq. trim(axis_name)) then + axis_id = i + return + endif + end select + enddo + + end function get_axis_id_from_name + + !< @brief Get the number of diurnal samples for a diurnal axis + !! @return The number of diurnal samples + pure function get_diurnal_axis_samples(this) & + result(n_diurnal_samples) + + class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Axis Object + integer :: n_diurnal_samples + + n_diurnal_samples = this%ndiurnal_samples + end function get_diurnal_axis_samples + + !< @brief Writes out the metadata for a diurnal axis + subroutine write_diurnal_metadata(this, fms2io_fileobj) + class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Diurnal axis Object + class(FmsNetcdfFile_t), intent(inout) :: fms2io_fileobj !< Fms2_io fileobj to write the data to + + call register_axis(fms2io_fileobj, this%axis_name, size(this%diurnal_data)) + call register_field(fms2io_fileobj, this%axis_name, pack_size_str, (/trim(this%axis_name)/)) + call register_variable_attribute(fms2io_fileobj, this%axis_name, "units", & + &trim(this%units), str_len=len_trim(this%units)) + call register_variable_attribute(fms2io_fileobj, this%axis_name, "long_name", & + &trim(this%long_name), str_len=len_trim(this%long_name)) + if (this%edges_id .ne. diag_null) & + call register_variable_attribute(fms2io_fileobj, this%axis_name, "edges", & + &trim(this%edges_name), str_len=len_trim(this%edges_name)) + end subroutine write_diurnal_metadata + + !> @brief Creates a new z subaxis to use + subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_axis_id, nfile_axis) + real(kind=r4_kind), intent(in) :: zbounds(2) !< Bounds of the Z axis + integer, intent(inout) :: var_axis_ids(:) !< The variable's axis_ids + class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Array of diag_axis objects + integer, intent(inout) :: naxis !< Number of axis that have been + !! registered + integer, intent(inout) :: file_axis_id(:) !< The file's axis_ids + integer, intent(inout) :: nfile_axis !< Number of axis that have been + !! defined in file + + class(*), pointer :: zaxis_data(:) !< The data of the full zaxis + integer :: subaxis_indices(2) !< The starting and ending indices of the subaxis relative to the full + !! axis + integer :: i !< For do loops + integer :: subaxis_id !< The id of the new z subaxis + logical :: axis_found !< Flag that indicated if the zsubaxis already exists + + !< Determine if the axis was already created + axis_found = .false. + do i = 1, nfile_axis + select type (axis => diag_axis(file_axis_id(i))%axis) + type is (fmsDiagSubAxis_type) + if (axis%zbounds(1) .eq. zbounds(1) .and. axis%zbounds(2) .eq. zbounds(2)) then + axis_found = .true. + subaxis_id = file_axis_id(i) + exit + endif + end select + enddo + + !< Determine which of the variable's axis is the zaxis! + do i = 1, size(var_axis_ids) + select type (parent_axis => diag_axis(var_axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + if (parent_axis%cart_name .eq. "Z") then + !< If the axis was previously defined set the var_axis_ids and leave + if (axis_found) then + var_axis_ids(i) = subaxis_id + return + endif + zaxis_data => parent_axis%axis_data + + select type(zaxis_data) + type is (real(kind=r4_kind)) + !TODO need to include the conversion to "real" because nearest_index doesn't take r4s and r8s + subaxis_indices(1) = nearest_index(real(zbounds(1)), real(zaxis_data)) + subaxis_indices(2) = nearest_index(real(zbounds(2)), real(zaxis_data)) + type is (real(kind=r8_kind)) + subaxis_indices(1) = nearest_index(real(zbounds(1)), real(zaxis_data)) + subaxis_indices(2) = nearest_index(real(zbounds(2)), real(zaxis_data)) + end select + + call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, & + &subaxis_indices(1), subaxis_indices(2), (/lbound(zaxis_data,1), ubound(zaxis_data,1)/), & + &subaxis_id, zbounds) + var_axis_ids(i) = subaxis_id + return + endif + end select + enddo + + end subroutine +#endif +end module fms_diag_axis_object_mod +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 7fa331258a..81c0a33d51 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -30,7 +30,7 @@ !> @{ MODULE fms_diag_bbox_mod - USE fms_mod, ONLY: error_mesg, FATAL + USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler, string implicit none @@ -39,28 +39,100 @@ MODULE fms_diag_bbox_mod !! array index bounds of the spatial component a diag_manager field output !! buffer array. TYPE, public :: fmsDiagIbounds_type - PRIVATE INTEGER :: imin !< Lower i bound. INTEGER :: imax !< Upper i bound. INTEGER :: jmin !< Lower j bound. INTEGER :: jmax !< Upper j bound. INTEGER :: kmin !< Lower k bound. INTEGER :: kmax !< Upper k bound. + logical :: has_halos !< .True. if the buffer has halos + integer :: nhalo_I !< Number of halos in i + integer :: nhalo_J !< Number of halos in j contains procedure :: reset => reset_bounds procedure :: reset_bounds_from_array_4D procedure :: reset_bounds_from_array_5D procedure :: update_bounds + procedure :: set_bounds + procedure :: rebase_input + procedure :: rebase_output procedure :: get_imin procedure :: get_imax procedure :: get_jmin procedure :: get_jmax procedure :: get_kmin procedure :: get_kmax + procedure :: update_index END TYPE fmsDiagIbounds_type + !> @brief Data structure holding starting and ending indices in the I, J, and + !! K dimensions. It also has extra members related to halo sizes and updated indices + !! in I and J dimensions. + type, public :: fmsDiagBoundsHalos_type + private + type(fmsDiagIbounds_type) :: bounds3D !< Holds starting and ending indices of + !! the I, J, and K dimensions + integer :: hi !< Halo size in the I dimension + integer :: hj !< Halo size in the J dimension + integer :: fis !< Updated starting index in the I dimension + integer :: fie !< Updated ending index in the I dimension + integer :: fjs !< Updated starting index in the J dimension + integer :: fje !< Updated ending index in the J dimension + contains + procedure :: get_hi + procedure :: get_hj + procedure :: get_fis + procedure :: get_fie + procedure :: get_fjs + procedure :: get_fje + end type fmsDiagBoundsHalos_type + + public :: recondition_indices, determine_if_block_is_in_region + + integer, parameter :: xdimension = 1 !< Parameter defining the x dimension + integer, parameter :: ydimension = 2 !< Parameter defining the y dimension + integer, parameter :: zdimension = 3 !< Parameter defininf the z dimension + CONTAINS +!> @brief The PEs grid points are divided further into "blocks". This function determines if a block +! has data for a given subregion and dimension +!! @return .true. if the a subergion is inside a block +logical pure function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dim) + integer, intent(in) :: subregion_start !< Begining of the subregion + integer, intent(in) :: subregion_end !< Ending of the subregion + type(fmsDiagIbounds_type), intent(in) :: bounds !< Starting and ending of the subregion + integer, intent(in) :: dim !< Dimension to check + + integer :: block_start !< Begining index of the block + integer :: block_end !< Ending index of the block + + determine_if_block_is_in_region = .true. + select case (dim) + case (xdimension) + block_start = bounds%imin + block_end = bounds%imax + case (ydimension) + block_start = bounds%jmin + block_end = bounds%jmax + case (zdimension) + block_start = bounds%kmin + block_end = bounds%kmax + end select + + if (block_start < subregion_start .and. block_end < subregion_start) then + determine_if_block_is_in_region = .false. + return + endif + + if (block_start > subregion_end .and. block_end > subregion_end) then + determine_if_block_is_in_region = .false. + return + endif + + determine_if_block_is_in_region = .true. +end function determine_if_block_is_in_region + !> @brief Gets imin of fmsDiagIbounds_type !! @return copy of integer member imin pure integer function get_imin (this) result(rslt) @@ -104,6 +176,83 @@ pure integer function get_kmax (this) result(rslt) rslt = this%kmax end function get_kmax + !> @brief Updates the starting and ending index of a given dimension + subroutine update_index(this, starting_index, ending_index, dim, ignore_halos) + class (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box to update + integer, intent(in) :: starting_index !< Starting index to update to + integer, intent(in) :: ending_index !< Ending index to update to + integer, intent(in) :: dim !< Dimension to update + logical, intent(in) :: ignore_halos !< If .true. halos will be ignored + !! i.e output buffers can ignore halos as + !! they do not get updates. The indices of the + !! Input buffers need to add the number of halos + !! so math is done only on the compute domain + + integer :: nhalox !< Number of halos in x + integer :: nhaloy !< Number of halos in y + + if (ignore_halos) then + nhalox = 0 + nhaloy = 0 + else + nhalox= this%nhalo_I + nhaloy= this%nhalo_J + endif + select case(dim) + case (xdimension) + this%imin = starting_index + nhalox + this%imax = ending_index + nhalox + case (ydimension) + this%jmin = starting_index + nhaloy + this%jmax = ending_index + nhaloy + case (zdimension) + this%kmin = starting_index + this%kmax = ending_index + end select + end subroutine + + !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the I dimension + !! @return copy of integer member hi + pure integer function get_hi (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%hi + end function get_hi + + !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the J dimension + !! @return copy of integer member hj + pure integer function get_hj (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%hj + end function get_hj + + !> @brief Gets the updated index `fis' of fmsDiagBoundsHalos_type in the I dimension + !! @return copy of integer member `fis' + pure integer function get_fis (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%fis + end function get_fis + + !> @brief Gets the updated index `fie' of fmsDiagBoundsHalos_type in the I dimension + !! @return copy of integer member `fie' + pure integer function get_fie (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%fie + end function get_fie + + !> @brief Gets the updated index `fjs' of fmsDiagBoundsHalos_type in the I dimension + !! @return copy of integer member `fjs' + pure integer function get_fjs (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%fjs + end function get_fjs + + !> @brief Gets the updated index `fje' of fmsDiagBoundsHalos_type in the I dimension + !! @return copy of integer member `fje' + pure integer function get_fje (this) result(rslt) + class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + rslt = this%fje + end function get_fje + !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. SUBROUTINE reset_bounds (this, lower_val, upper_val) class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance @@ -136,17 +285,78 @@ SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, uppe this%kmax = MAX(this%kmax, upper_k) END SUBROUTINE update_bounds + !> @brief Sets the bounds of a bounding region + !! @return empty string if sucessful or error message if unsucessful + function set_bounds(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k, has_halos) & + result(error_msg) + CLASS (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box of the field + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + INTEGER, INTENT(in) :: lower_i !< Lower i bound. + INTEGER, INTENT(in) :: upper_i !< Upper i bound. + INTEGER, INTENT(in) :: lower_j !< Lower j bound. + INTEGER, INTENT(in) :: upper_j !< Upper j bound. + INTEGER, INTENT(in) :: lower_k !< Lower k bound. + INTEGER, INTENT(in) :: upper_k !< Upper k bound. + LOGICAL, INTENT(in) :: has_halos !< .true. if the field has halos + + character(len=150) :: error_msg !< Error message to output + + integer :: nhalos_2 !< 2 times the number of halo points + integer :: nhalox !< Number of halos in x + integer :: nhaloy !< Number of halos in y + + error_msg = "" + this%kmin = lower_k + this%kmax = upper_k + this%has_halos = has_halos + this%nhalo_I = 0 + this%nhalo_J = 0 + if (has_halos) then + !upper_i-lower_i+1 is the size of the compute domain + !ubound(field_data,1) is the size of the data domain + nhalos_2 = ubound(field_data,1)-(upper_i-lower_i+1) + if (mod(nhalos_2, 2) .ne. 0) then + error_msg = "There are non-symmetric halos in the first dimension" + return + endif + nhalox = nhalos_2/2 + this%nhalo_I = nhalox + + nhalos_2 = ubound(field_data,2)-(upper_j-lower_j + 1) + if (mod(nhalos_2, 2) .ne. 0) then + error_msg = "There are non-symmetric halos in the second dimension" + return + endif + nhaloy = nhalos_2/2 + this%nhalo_J = nhaloy + + this%imin = 1 + nhalox + this%imax = ubound(field_data,1) - nhalox + this%jmin = 1 + nhaloy + this%jmax = ubound(field_data,2) - nhaloy + else + this%imin = lower_i + this%imax = upper_i + this%jmin = lower_j + this%jmax = upper_j + endif + + end function set_bounds !> @brief Reset the instance bounding box with the bounds determined from the !! first three dimensions of the 5D "array" argument SUBROUTINE reset_bounds_from_array_4D(this, array) CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. - REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + class(*), INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. this%imin = LBOUND(array,1) this%imax = UBOUND(array,1) this%jmin = LBOUND(array,2) this%jmax = UBOUND(array,2) this%kmin = LBOUND(array,3) this%kmax = UBOUND(array,3) + + this%has_halos = .false. + this%nhalo_I = 0 + this%nhalo_J = 0 END SUBROUTINE reset_bounds_from_array_4D !> @brief Reset the instance bounding box with the bounds determined from the @@ -162,6 +372,156 @@ SUBROUTINE reset_bounds_from_array_5D(this, array) this%kmax = UBOUND(array,3) END SUBROUTINE reset_bounds_from_array_5D + !> @brief Updates indices based on presence/absence of input indices is, js, ks, ie, je, and ke. + ! Computes halo sizes in the I and J dimensions. + ! This routine is intended to be used in diag manager. + !> @return .false. if there is no error else .true. + function recondition_indices(indices, field, is_in, js_in, ks_in, & + ie_in, je_in, ke_in, err_msg) result(ierr) + type(fmsDiagBoundsHalos_type), intent(inout) :: indices !< Stores indices in order: + !! (/is, js, ks, ie, je, ke, hi, fis, fie, hj, fjs, fje/) + class(*), intent(in) :: field(:,:,:,:) !< Dummy variable; only the sizes of the first 3 dimensions are used + integer, intent(in), optional :: is_in, js_in, ks_in, ie_in, je_in, ke_in !< User input indices + character(len=*), intent(out), optional :: err_msg !< Error message to pass back to caller + logical :: ierr !< Error flag + + integer :: is, js, ks, ie, je, ke !< Local indices to update + integer :: hi !< halo size in the I dimension + integer :: hj !< halo size in the J dimension + integer :: twohi, twohj !< Temporary storages + integer :: fis, fie, fjs, fje !< ! Updated starting and ending indices in the I and J dimensions + integer :: n1, n2, n3 !< Sizes of the first 3 dimenstions indicies of the data + + ierr = .false. + if (present(err_msg)) err_msg = '' + + ! If is, js, or ks not present default them to 1 + is = 1 + js = 1 + ks = 1 + + IF ( PRESENT(is_in) ) is = is_in + IF ( PRESENT(js_in) ) js = js_in + IF ( PRESENT(ks_in) ) ks = ks_in + + n1 = SIZE(field, 1) + n2 = SIZE(field, 2) + n3 = SIZE(field, 3) + + ie = is + n1 - 1 + je = js + n2 - 1 + ke = ks + n3 - 1 + + IF ( PRESENT(ie_in) ) ie = ie_in + IF ( PRESENT(je_in) ) je = je_in + IF ( PRESENT(ke_in) ) ke = ke_in + + twohi = n1 - (ie - is + 1) + IF ( MOD(twohi, 2) /= 0 ) THEN + ierr = fms_error_handler('diag_util_mod:recondition_indices', & + 'non-symmetric halos in first dimension', err_msg) + IF (ierr) RETURN + END IF + + twohj = n2 - (je - js + 1) + IF ( MOD(twohj, 2) /= 0 ) THEN + ierr = fms_error_handler('diag_util_mod:recondition_indices', & + 'non-symmetric halos in second dimension', err_msg) + IF (ierr) RETURN + END IF + + hi = twohi/2 + hj = twohj/2 + + ! The next line is necessary to ensure that is, ie, js, ie are relative to field(1:,1:) + ! But this works only when there is no windowing. + IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN + is = 1 + hi + ie = n1 - hi + js = 1 + hj + je = n2 - hj + END IF + + ! Used for field, mask and rmask bounds + fis = 1 + hi + fie = n1 - hi + fjs = 1 + hj + fje = n2 - hj + + ! Update indices + indices%bounds3D%imin = is + indices%bounds3D%imax = ie + indices%bounds3D%jmin = js + indices%bounds3D%jmax = je + indices%bounds3D%kmin = ks + indices%bounds3D%kmax = ke + indices%hi = hi + indices%hj = hj + indices%fis = fis + indices%fie = fie + indices%fjs = fjs + indices%fje = fje + end function recondition_indices + + !> @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices of + !! a subregion. This is for when blocking is used. + subroutine rebase_output(bounds_out, starting, ending, dim) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out !< Bounds to rebase + integer, intent(in) :: starting !< Starting index of the dimension + integer, intent(in) :: ending !< Ending index of the dimension + integer, intent(in) :: dim !< Dimension to update + + !> The starting index is going to be either "starting" if only a section of the + !! block is in the subregion or bounds_out%[]min if the whole section of the block is in the + !! subregion. The -starting+1 s needed so that indices start as 1 since the output buffer has + !! indices 1:size of a subregion + + !> The ending index is going to be either bounds_out%[]max if the whole section of the block + !! is in the subregion or bounds_out%[]min + size of the subregion if only a section of the + !! block is in the susbregion + select case (dim) + case (xdimension) + bounds_out%imin = max(starting, bounds_out%imin)-starting+1 + bounds_out%imax = min(bounds_out%imax, bounds_out%imin + ending-starting) + case (ydimension) + bounds_out%jmin = max(starting, bounds_out%jmin)-starting+1 + bounds_out%jmax = min(bounds_out%jmax, bounds_out%jmin + ending-starting) + case (zdimension) + bounds_out%kmin =max(starting, bounds_out%kmin)-starting+1 + bounds_out%kmax = min(bounds_out%kmax, bounds_out%kmin + ending-starting) + end select + end subroutine + + !> @brief Rebase the input bounds for a given dimension based on the starting and ending indices + !! of a subregion. This is for when blocking is used + subroutine rebase_input(bounds_in, bounds, starting, ending, dim) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in !< Bounds to rebase + CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds !< Original indices (i.e is_in, ie_in, + !! passed into diag_manager) + integer, intent(in) :: starting !< Starting index of the dimension + integer, intent(in) :: ending !< Ending index of the dimension + integer, intent(in) :: dim !< Dimension to update + + !> The starting index is going to be either "starting" if only a section of the + !! block is in the subregion or starting-bounds%imin+1 if the whole section of the block is in the + !! subregion. + + !> The ending index is going to be either bounds_out%[]max if the whole section of the block + !! is in the subregion or bounds%[]min + size of the subregion if only a section of the + !! block is in the susbregion + select case (dim) + case (xdimension) + bounds_in%imin = min(abs(starting-bounds%imin+1), starting) + bounds_in%imax = min(bounds_in%imax, (bounds_in%imin + ending-starting)) + case (ydimension) + bounds_in%jmin = min(abs(starting-bounds%jmin+1), starting) + bounds_in%jmax = min(bounds_in%jmax, (bounds_in%jmin + ending-starting)) + case (zdimension) + bounds_in%kmin = min(abs(starting-bounds%kmin+1), starting) + bounds_in%kmax = min(bounds_in%kmax, (bounds_in%kmin + ending-starting)) + end select + end subroutine + END MODULE fms_diag_bbox_mod !> @} ! close documentation grouping diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90 new file mode 100644 index 0000000000..c220ef62e2 --- /dev/null +++ b/diag_manager/fms_diag_dlinked_list.F90 @@ -0,0 +1,341 @@ +!*********************************************************************** +!* 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 + + private + + !> 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=>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=>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 + + 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 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 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 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_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 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 + 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. !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 +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 new file mode 100644 index 0000000000..e723ce8410 --- /dev/null +++ b/diag_manager/fms_diag_field_object.F90 @@ -0,0 +1,1696 @@ +module fms_diag_field_object_mod +!> \author Tom Robinson +!> \email thomas.robinson@noaa.gov +!! \brief Contains routines for the diag_objects +!! +!! \description The diag_manager passes an object back and forth between the diag routines and the users. +!! The procedures of this object and the types are all in this module. The fms_dag_object is a type +!! that contains all of the information of the variable. It is extended by a type that holds the +!! appropriate buffer for the data for manipulation. +#ifdef use_yaml +use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string, MAX_STR_LEN +use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN +use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type +use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & + &DIAG_FIELD_NOT_FOUND, avg_name, time_average, time_min, time_max, & + &time_none, time_diurnal, time_power, time_rms, time_sum +use fms_string_utils_mod, only: int2str=>string +use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe +use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, & + & find_diag_field, get_num_unique_fields, diag_yaml +use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, & + & fmsDiagAxisContainer_type, fmsDiagFullAxis_Type +use time_manager_mod, ONLY: time_type +use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, register_field, & + register_variable_attribute +use fms_diag_input_buffer_mod, only: fmsDiagInputBuffer_t +!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& +!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & +!!! & get_ticks_per_second + +use platform_mod +use iso_c_binding + +implicit none + +private + +!> \brief Object that holds all variable information +type fmsDiagField_type + type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable + integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable + !! belongs to + integer, allocatable, private :: diag_id !< unique id for varable + integer, allocatable, dimension(:) :: buffer_ids !< index/id for this field's buffers + type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable + integer, private :: num_attributes !< Number of attributes currently added + logical, allocatable, private :: static !< true if this is a static var + logical, allocatable, private :: scalar !< .True. if the variable is a scalar + logical, allocatable, private :: registered !< true when registered + logical, allocatable, private :: mask_variant !< If there is a mask variant + logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field + logical, allocatable, private :: local !< If the output is local + integer, allocatable, private :: vartype !< the type of varaible + character(len=:), allocatable, private :: varname !< the name of the variable + character(len=:), allocatable, private :: longname !< longname of the variable + character(len=:), allocatable, private :: standname !< standard name of the variable + character(len=:), allocatable, private :: units !< the units + character(len=:), allocatable, private :: modname !< the module + character(len=:), allocatable, private :: realm !< String to set as the value + !! to the modeling_realm attribute + character(len=:), allocatable, private :: interp_method !< The interp method to be used + !! when regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + integer, allocatable, dimension(:), private :: frequency !< specifies the frequency + integer, allocatable, private :: tile_count !< The number of tiles + integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs + class(diagDomain_t), pointer, private :: domain !< Domain + INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", + !! "TWO_D_DOMAIN", or "UG_DOMAIN") + integer, allocatable, private :: area, volume !< The Area and Volume + class(*), allocatable, private :: missing_value !< The missing fill value + class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data + type(fmsDiagInputBuffer_t), allocatable :: input_data_buffer !< Input buffer object for when buffering + !! data + logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has + !! been allocated + logical, allocatable, private :: math_needs_to_be_done !< If true, do math + !! functions. False when done. + logical, allocatable :: buffer_allocated !< True if a buffer pointed by + !! the corresponding index in + !! buffer_ids(:) is allocated. + logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data + contains +! procedure :: send_data => fms_send_data !!TODO +! Get ID functions + procedure :: get_id => fms_diag_get_id + procedure :: id_from_name => diag_field_id_from_name + procedure :: copy => copy_diag_obj + procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. + procedure :: setID => set_diag_id + procedure :: set_type => set_vartype + procedure :: set_data_buffer => set_data_buffer + procedure :: set_data_buffer_is_allocated + procedure :: is_data_buffer_allocated + procedure :: allocate_data_buffer + procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done + procedure :: add_attribute => diag_field_add_attribute + procedure :: vartype_inq => what_is_vartype + procedure :: set_mask_variant +! Check functions + procedure :: is_static => diag_obj_is_static + procedure :: is_scalar + procedure :: is_registered => get_registered + procedure :: is_registeredB => diag_obj_is_registered + procedure :: is_mask_variant => get_mask_variant + procedure :: is_local => get_local +! Is variable allocated check functions +!TODO procedure :: has_diag_field + procedure :: has_diag_id + procedure :: has_attributes + procedure :: has_static + procedure :: has_registered + procedure :: has_mask_variant + procedure :: has_local + procedure :: has_vartype + procedure :: has_varname + procedure :: has_longname + procedure :: has_standname + procedure :: has_units + procedure :: has_modname + procedure :: has_realm + procedure :: has_interp_method + procedure :: has_frequency + procedure :: has_tile_count + procedure :: has_axis_ids + procedure :: has_area + procedure :: has_volume + procedure :: has_missing_value + procedure :: has_data_RANGE + procedure :: has_input_data_buffer +! Get functions + procedure :: get_attributes + procedure :: get_static + procedure :: get_registered + procedure :: get_mask_variant + procedure :: get_local + procedure :: get_vartype + procedure :: get_varname + procedure :: get_longname + procedure :: get_standname + procedure :: get_units + procedure :: get_modname + procedure :: get_realm + procedure :: get_interp_method + procedure :: get_frequency + procedure :: get_tile_count + procedure :: get_area + procedure :: get_volume + procedure :: get_missing_value + procedure :: get_data_RANGE + procedure :: get_axis_id + procedure :: get_data_buffer + procedure :: get_mask + procedure :: get_weight + procedure :: dump_field_obj + procedure :: get_domain + procedure :: get_type_of_domain + procedure :: set_file_ids + procedure :: get_dimnames + procedure :: get_var_skind + procedure :: get_longname_to_write + procedure :: write_field_metadata + procedure :: write_coordinate_attribute + procedure :: get_math_needs_to_be_done + procedure :: add_area_volume + procedure :: append_time_cell_methods + procedure :: get_file_ids + procedure :: set_mask + procedure :: allocate_mask +end type fmsDiagField_type +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +type(fmsDiagField_type) :: null_ob + +logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized + +!type(fmsDiagField_type) :: diag_object_placeholder (10) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +public :: fmsDiagField_type +public :: fms_diag_fields_object_init +public :: null_ob +public :: fms_diag_field_object_end +public :: get_default_missing_value +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> @brief Deallocates the array of diag_objs +subroutine fms_diag_field_object_end (ob) + class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object + if (allocated(ob)) deallocate(ob) + module_is_initialized = .false. +end subroutine fms_diag_field_object_end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \Description Allocates the diad field object array. +!! Sets the diag_id to the not registered value. +!! Initializes the number of registered variables to be 0 +logical function fms_diag_fields_object_init(ob) + class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object + integer :: i !< For looping + allocate(ob(get_num_unique_fields())) + do i = 1,size(ob) + ob(i)%diag_id = diag_not_registered !null_ob%diag_id + ob(i)%registered = .false. + enddo + module_is_initialized = .true. + fms_diag_fields_object_init = .true. +end function fms_diag_fields_object_init +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \Description Fills in and allocates (when necessary) the values in the diagnostic object +subroutine fms_register_diag_field_obj & + (this, modname, varname, diag_field_indices, diag_axis, axes, & + longname, units, missing_value, varRange, mask_variant, standname, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static) + + class(fmsDiagField_type), INTENT(inout) :: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: modname !< The module name + CHARACTER(len=*), INTENT(in) :: varname !< The variable name + integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field + !! in the yaml object + class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis + INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies + CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name + class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute + class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field + +!> Fill in information from the register call + this%varname = trim(varname) + this%modname = trim(modname) + +!> Add the yaml info to the diag_object + this%diag_field = get_diag_fields_entries(diag_field_indices) + +!> Add axis and domain information + if (present(axes)) then + this%scalar = .false. + this%axis_ids = axes + call get_domain_and_domain_type(diag_axis, this%axis_ids, this%type_of_domain, this%domain, this%varname) + else + !> The variable is a scalar + this%scalar = .true. + this%type_of_domain = NO_DOMAIN + this%domain => null() + endif + +!> get the optional arguments if included and the diagnostic is in the diag table + if (present(longname)) this%longname = trim(longname) + if (present(standname)) this%standname = trim(standname) + + !> Ignore the units if they are set to "none". This is to reproduce previous diag_manager behavior + if (present(units)) then + if (trim(units) .ne. "none") this%units = trim(units) + endif + if (present(realm)) this%realm = trim(realm) + if (present(interp_method)) this%interp_method = trim(interp_method) + + if (present(tile_count)) then + allocate(this%tile_count) + this%tile_count = tile_count + endif + if (present(static)) then + this%static = static + else + this%static = .false. + endif + + if (present(missing_value)) then + select type (missing_value) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%missing_value) + this%missing_value = missing_value + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%missing_value) + this%missing_value = missing_value + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%missing_value) + this%missing_value = missing_value + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: this%missing_value) + this%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 + endif + + if (present(varRANGE)) then + select type (varRANGE) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (real(kind=r4_kind)) + allocate(integer(kind=r4_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (real(kind=r8_kind)) + allocate(integer(kind=r8_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + class default + call mpp_error("fms_register_diag_field_obj", & + "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",& + FATAL) + end select + endif + + if (present(area)) then + if (area < 0) call mpp_error("fms_register_diag_field_obj", & + "The area id passed with field_name"//trim(varname)//" has not been registered."& + "Check that there is a register_diag_field call for the AREA measure and that is in the"& + "diag_table.yaml", FATAL) + allocate(this%area) + this%area = area + endif + + if (present(volume)) then + if (volume < 0) call mpp_error("fms_register_diag_field_obj", & + "The volume id passed with field_name"//trim(varname)//" has not been registered."& + "Check that there is a register_diag_field call for the VOLUME measure and that is in the"& + "diag_table.yaml", FATAL) + allocate(this%volume) + this%volume = volume + endif + + if (present(mask_variant)) then + allocate(this%mask_variant) + this%mask_variant = mask_variant + endif + + if (present(do_not_log)) then + allocate(this%do_not_log) + this%do_not_log = do_not_log + endif + + !< Allocate space for any additional variable attributes + !< These will be fill out when calling `diag_field_add_attribute` + allocate(this%attributes(max_field_attributes)) + this%num_attributes = 0 + this%registered = .true. +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(this , id) + class (fmsDiagField_type) , intent(inout):: this + integer :: id + if (allocated(this%registered)) then + if (this%registered) then + call mpp_error("set_diag_id", "The variable"//this%varname//" is already registered", FATAL) + else + this%diag_id = id + endif + else + this%diag_id = id + endif +end subroutine set_diag_id + +!> \brief Find the type of the variable and store it in the object +subroutine set_vartype(objin , var) + class (fmsDiagField_type) , intent(inout):: objin + class(*) :: var + select type (var) + type is (real(kind=8)) + objin%vartype = r8 + type is (real(kind=4)) + objin%vartype = r4 + type is (integer(kind=8)) + objin%vartype = i8 + type is (integer(kind=4)) + objin%vartype = i4 + type is (character(*)) + objin%vartype = string + class default + objin%vartype = null_type_int + call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// & + " r8, r4, i8, i4, or string.", warning) + end select +end subroutine set_vartype + +!> @brief Adds the input data to the buffered data. +subroutine set_data_buffer (this, input_data, weight, is, js, ks, ie, je, ke) + class (fmsDiagField_type) , intent(inout):: this !< The field object + class(*), intent(in) :: input_data(:,:,:,:) !< The input array + real(kind=r8_kind), intent(in) :: weight !< The field weight + integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative + !! to the compute domain (1 based) + integer, intent(in) :: ie, je, ke !< Ending indicies of the field_data relative + !! to the compute domain (1 based) + + character(len=128) :: err_msg !< Error msg + if (.not.this%data_buffer_is_allocated) & + call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//& + "allocated.", FATAL) + err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke) + if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg)) + +end subroutine set_data_buffer +!> Allocates the global data buffer for a given field using a single thread. Returns true when the +!! buffer is allocated +logical function allocate_data_buffer(this, input_data, diag_axis) + class (fmsDiagField_type), target, intent(inout):: this !< The field object + class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array + class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis + + character(len=128) :: err_msg !< Error msg + err_msg = "" + + allocate(this%input_data_buffer) + err_msg = this%input_data_buffer%init(input_data, this%axis_ids, diag_axis) + if (trim(err_msg) .ne. "") then + call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg)) + return + endif + + allocate_data_buffer = .true. +end function allocate_data_buffer +!> Sets the flag saying that the math functions need to be done +subroutine set_math_needs_to_be_done (this, math_needs_to_be_done) + class (fmsDiagField_type) , intent(inout):: this + logical, intent (in) :: math_needs_to_be_done !< Flag saying that the math functions need to be done + this%math_needs_to_be_done = math_needs_to_be_done +end subroutine set_math_needs_to_be_done + +!> @brief Set the mask_variant to .true. +subroutine set_mask_variant(this, is_masked) + class (fmsDiagField_type) , intent(inout):: this !< The diag field object + logical, intent (in) :: is_masked !< .True. if the field is masked + + this%mask_variant = is_masked +end subroutine set_mask_variant + +!> @brief Sets the flag saying that the data buffer is allocated +subroutine set_data_buffer_is_allocated (this, data_buffer_is_allocated) + class (fmsDiagField_type) , intent(inout) :: this !< The field object + logical, intent (in) :: data_buffer_is_allocated !< .true. if the + !! data buffer is allocated + this%data_buffer_is_allocated = data_buffer_is_allocated +end subroutine set_data_buffer_is_allocated + +!> @brief Determine if the data_buffer is allocated +!! @return logical indicating if the data_buffer is allocated +pure logical function is_data_buffer_allocated (this) + class (fmsDiagField_type) , intent(in) :: this !< The field object + + is_data_buffer_allocated = .false. + if (allocated(this%data_buffer_is_allocated)) is_data_buffer_allocated = this%data_buffer_is_allocated + +end function +!> \brief Prints to the screen what type the diag variable is +subroutine what_is_vartype(this) + class (fmsDiagField_type) , intent(inout):: this + if (.not. allocated(this%vartype)) then + call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning) + return + endif + select case (this%vartype) + case (r8) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is REAL(kind=8)", NOTE) + case (r4) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is REAL(kind=4)", NOTE) + case (i8) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is INTEGER(kind=8)", NOTE) + case (i4) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is INTEGER(kind=4)", NOTE) + case (string) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is CHARACTER(*)", NOTE) + case (null_type_int) + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " was not set", WARNING) + case default + call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//& + " is not supported by diag_manager", FATAL) + end select +end subroutine what_is_vartype +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> \brief Copies the calling object into the object that is the argument of the subroutine +subroutine copy_diag_obj(this , objout) + class (fmsDiagField_type) , intent(in) :: this + class (fmsDiagField_type) , intent(inout) , allocatable :: objout !< The destination of the copy +select type (objout) + class is (fmsDiagField_type) + + if (allocated(this%registered)) then + objout%registered = this%registered + else + call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning) + endif + objout%diag_id = this%diag_id + + if (allocated(this%attributes)) objout%attributes = this%attributes + objout%static = this%static + if (allocated(this%frequency)) objout%frequency = this%frequency + if (allocated(this%varname)) objout%varname = this%varname +end select +end subroutine copy_diag_obj +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> \brief Returns the ID integer for a variable +!! \return the diag ID +pure integer function fms_diag_get_id (this) result(diag_id) + class(fmsDiagField_type) , intent(in) :: this +!> Check if the diag_object registration has been done + if (allocated(this%registered)) then + !> Return the diag_id if the variable has been registered + diag_id = this%diag_id + else +!> If the variable is not regitered, then return the unregistered value + diag_id = DIAG_NOT_REGISTERED + endif +end function fms_diag_get_id + +!> Function to return a character (string) representation of the most basic +!> object identity info. Intended for debugging and warning. The format produced is: +!> [this: 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(this) result(rslt) + class(fmsDiagField_type), allocatable, intent(in) :: this + character(:), allocatable :: rslt + character (len=:), allocatable :: registered, vartype, varname, diag_id + if ( .not. allocated (this)) then + varname = "?" + vartype = "?" + registered = "?" + diag_id = "?" + rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" + return + end if + +! if(allocated (this%registered)) then +! registered = logical_to_cs (this%registered) +! else +! registered = "?" +! end if + +! if(allocated (this%diag_id)) then +! diag_id = int_to_cs (this%diag_id) +! else +! diag_id = "?" +! end if + +! if(allocated (this%vartype)) then +! vartype = int_to_cs (this%vartype) +! else +! registered = "?" +! end if + + if(allocated (this%varname)) then + varname = this%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 (this) result (rslt) + class(fmsDiagField_type), intent(in) :: this + logical :: rslt + rslt = this%registered +end function diag_obj_is_registered + +function diag_obj_is_static (this) result (rslt) + class(fmsDiagField_type), intent(in) :: this + logical :: rslt + rslt = .false. + if (allocated(this%static)) rslt = this%static +end function diag_obj_is_static + +!> @brief Determine if the field is a scalar +!! @return .True. if the field is a scalar +function is_scalar (this) result (rslt) + class(fmsDiagField_type), intent(in) :: this !< diag_field object + logical :: rslt + rslt = this%scalar +end function is_scalar + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Get functions + +!> @brief Gets attributes +!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes +function get_attributes (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag object + type(fmsDiagAttribute_type), pointer :: rslt(:) + + rslt => null() + if (this%num_attributes > 0 ) rslt => this%attributes +end function get_attributes + +!> @brief Gets static +!! @return copy of variable static +pure function get_static (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%static +end function get_static + +!> @brief Gets regisetered +!! @return copy of registered +pure function get_registered (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%registered +end function get_registered + +!> @brief Gets mask variant +!! @return copy of mask variant +pure function get_mask_variant (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = .false. + if (allocated(this%mask_variant)) rslt = this%mask_variant +end function get_mask_variant + +!> @brief Gets local +!! @return copy of local +pure function get_local (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%local +end function get_local + +!> @brief Gets vartype +!! @return copy of The integer related to the variable type +pure function get_vartype (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + rslt = this%vartype +end function get_vartype + +!> @brief Gets varname +!! @return copy of the variable name +pure function get_varname (this, to_write) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical, optional, intent(in) :: to_write !< .true. if getting the varname that will be writen to the file + character(len=:), allocatable :: rslt + rslt = this%varname + + !< If writing the varname can be the outname which is defined in the yaml + if (present(to_write)) then + if (to_write) then + !TODO this is wrong + rslt = this%diag_field(1)%get_var_outname() + endif + endif + +end function get_varname + +!> @brief Gets longname +!! @return copy of the variable long name or a single string if there is no long name +pure function get_longname (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%longname)) then + rslt = this%longname + else + rslt = diag_null_string + endif +end function get_longname + +!> @brief Gets standname +!! @return copy of the standard name or an empty string if standname is not allocated +pure function get_standname (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%standname)) then + rslt = this%standname + else + rslt = diag_null_string + endif +end function get_standname + +!> @brief Gets units +!! @return copy of the units or an empty string if not allocated +pure function get_units (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%units)) then + rslt = this%units + else + rslt = diag_null_string + endif +end function get_units + +!> @brief Gets modname +!! @return copy of the module name that the variable is in or an empty string if not allocated +pure function get_modname (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%modname)) then + rslt = this%modname + else + rslt = diag_null_string + endif +end function get_modname + +!> @brief Gets realm +!! @return copy of the variables modeling realm or an empty string if not allocated +pure function get_realm (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%realm)) then + rslt = this%realm + else + rslt = diag_null_string + endif +end function get_realm + +!> @brief Gets interp_method +!! @return copy of The interpolation method or an empty string if not allocated +pure function get_interp_method (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + if (allocated(this%interp_method)) then + rslt = this%interp_method + else + rslt = diag_null_string + endif +end function get_interp_method + +!> @brief Gets frequency +!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated +pure function get_frequency (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer, allocatable, dimension (:) :: rslt + if (allocated(this%frequency)) then + allocate (rslt(size(this%frequency))) + rslt = this%frequency + else + allocate (rslt(1)) + rslt = DIAG_NULL + endif +end function get_frequency + +!> @brief Gets tile_count +!! @return copy of the number of tiles or diag_null if tile_count is not allocated +pure function get_tile_count (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + if (allocated(this%tile_count)) then + rslt = this%tile_count + else + rslt = DIAG_NULL + endif +end function get_tile_count + +!> @brief Gets area +!! @return copy of the area or diag_null if not allocated +pure function get_area (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + if (allocated(this%area)) then + rslt = this%area + else + rslt = diag_null + endif +end function get_area + +!> @brief Gets volume +!! @return copy of the volume or diag_null if volume is not allocated +pure function get_volume (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + if (allocated(this%volume)) then + rslt = this%volume + else + rslt = diag_null + endif +end function get_volume + +!> @brief Gets missing_value +!! @return copy of The missing value +!! @note Netcdf requires the type of the variable and the type of the missing_value and _Fillvalue to be the same +!! var_type is the type of the variable which may not be in the same type as the missing_value in the register call +!! For example, if compiling with r8 but the in diag_table.yaml the kind is r4 +function get_missing_value (this, var_type) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file + !! and the missing value is return as + + class(*),allocatable :: rslt + + if (.not. allocated(this%missing_value)) then + call mpp_error ("get_missing_value", & + "The missing value is not allocated", FATAL) + endif + + !< The select types are needed so that the missing_value can be correctly converted and copied as the needed variable + !! type + select case (var_type) + case (r4) + allocate (real(kind=r4_kind) :: rslt) + select type (miss => this%missing_value) + type is (real(kind=r4_kind)) + select type (rslt) + type is (real(kind=r4_kind)) + rslt = real(miss, kind=r4_kind) + end select + type is (real(kind=r8_kind)) + select type (rslt) + type is (real(kind=r4_kind)) + rslt = real(miss, kind=r4_kind) + end select + end select + case (r8) + allocate (real(kind=r8_kind) :: rslt) + select type (miss => this%missing_value) + type is (real(kind=r4_kind)) + select type (rslt) + type is (real(kind=r8_kind)) + rslt = real(miss, kind=r8_kind) + end select + type is (real(kind=r8_kind)) + select type (rslt) + type is (real(kind=r8_kind)) + rslt = real(miss, kind=r8_kind) + end select + end select + end select + +end function get_missing_value + +!> @brief Gets data_range +!! @return copy of the data range +!! @note Netcdf requires the type of the variable and the type of the range to be the same +!! var_type is the type of the variable which may not be in the same type as the range in the register call +!! For example, if compiling with r8 but the in diag_table.yaml the kind is r4 +function get_data_RANGE (this, var_type) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file + !! and the data_range is returned as + class(*),allocatable :: rslt(:) + + if ( .not. allocated(this%data_RANGE)) call mpp_error ("get_data_RANGE", & + "The data_RANGE value is not allocated", FATAL) + + !< The select types are needed so that the range can be correctly converted and copied as the needed variable + !! type + select case (var_type) + case (r4) + allocate (real(kind=r4_kind) :: rslt(2)) + select type (r => this%data_RANGE) + type is (real(kind=r4_kind)) + select type (rslt) + type is (real(kind=r4_kind)) + rslt = real(r, kind=r4_kind) + end select + type is (real(kind=r8_kind)) + select type (rslt) + type is (real(kind=r4_kind)) + rslt = real(r, kind=r4_kind) + end select + end select + case (r8) + allocate (real(kind=r8_kind) :: rslt(2)) + select type (r => this%data_RANGE) + type is (real(kind=r4_kind)) + select type (rslt) + type is (real(kind=r8_kind)) + rslt = real(r, kind=r8_kind) + end select + type is (real(kind=r8_kind)) + select type (rslt) + type is (real(kind=r8_kind)) + rslt = real(r, kind=r8_kind) + end select + end select + end select +end function get_data_RANGE + +!> @brief Gets axis_ids +!! @return pointer to the axis ids +function get_axis_id (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag object + integer, pointer, dimension(:) :: rslt !< field's axis_ids + + if(allocated(this%axis_ids)) then + rslt => this%axis_ids + else + rslt => null() + endif +end function get_axis_id + +!> @brief Gets field's domain +!! @return pointer to the domain +function get_domain (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + class(diagDomain_t), pointer :: rslt !< field's domain + + if (associated(this%domain)) then + rslt => this%domain + else + rslt => null() + endif + +end function get_domain + +!> @brief Gets field's type of domain +!! @return integer defining the type of domain (NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN) +pure function get_type_of_domain (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + integer :: rslt !< field's domain + + rslt = this%type_of_domain +end function get_type_of_domain + +!> @brief Set the file ids of the files that the field belongs to +subroutine set_file_ids(this, file_ids) + class (fmsDiagField_type), intent(inout) :: this !< diag field + integer, intent(in) :: file_ids(:) !< File_ids to add + + allocate(this%file_ids(size(file_ids))) + this%file_ids = file_ids +end subroutine set_file_ids + +!> @brief Get the kind of the variable based on the yaml +!! @return A string indicating the kind of the variable (as it is used in fms2_io) +pure function get_var_skind(this, field_yaml) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag field + type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The corresponding yaml of the field + + character(len=:), allocatable :: rslt + + integer :: var_kind !< The integer corresponding to the kind of the variable (i4, i8, r4, r8) + + var_kind = field_yaml%get_var_kind() + select case (var_kind) + case (r4) + rslt = "float" + case (r8) + rslt = "double" + case (i4) + rslt = "int" + case (i8) + rslt = "int64" + end select + +end function get_var_skind + +!> @brief Determine the long name to write for the field +!! @return Long name to write +pure function get_longname_to_write(this, field_yaml) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag field + type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The corresponding yaml of the field + + character(len=:), allocatable :: rslt + + rslt = field_yaml%get_var_longname() !! This is the long name defined in the yaml + if (rslt .eq. "") then !! If the long name is not defined in the yaml, use the long name in the + !! register_diag_field + rslt = this%get_longname() + else + return + endif + if (rslt .eq. "") then !! If the long name is not defined in the yaml and in the register_diag_field + !! use the variable name + rslt = field_yaml%get_var_outname() + endif +end function get_longname_to_write + +!> @brief Determine the dimension names to use when registering the field to fms2_io +subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is_regional) + class (fmsDiagField_type), target, intent(inout) :: this !< diag field + class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Diag_axis object + type(diagYamlFilesVar_type), intent(in) :: field_yaml !< Field info from diag_table yaml + character(len=*), intent(in) :: unlim_dimname !< The name of unlimited dimension + character(len=120), allocatable, intent(out) :: dimnames(:) !< Array of the dimension names + !! for the field + logical, intent(in) :: is_regional !< Flag indicating if the field is regional + + integer :: i !< For do loops + integer :: naxis !< Number of axis for the field + class(fmsDiagAxisContainer_type), pointer :: axis_ptr !diag_axis(this%axis_ids(i), for convenience + + if (this%is_static()) then + naxis = size(this%axis_ids) + else + naxis = size(this%axis_ids) + 1 !< Adding 1 more dimension for the unlimited dimension + endif + + if (field_yaml%has_n_diurnal()) then + naxis = naxis + 1 !< Adding 1 more dimension for the diurnal axis + endif + + allocate(dimnames(naxis)) + + !< Duplicated do loops for performance + if (field_yaml%has_var_zbounds()) then + do i = 1, size(this%axis_ids) + axis_ptr => diag_axis(this%axis_ids(i)) + if (axis_ptr%axis%is_z_axis()) then + dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)//"_sub01" + else + dimnames(i) = axis_ptr%axis%get_axis_name(is_regional) + endif + enddo + else + do i = 1, size(this%axis_ids) + axis_ptr => diag_axis(this%axis_ids(i)) + dimnames(i) = axis_ptr%axis%get_axis_name(is_regional) + enddo + endif + + !< The second to last dimension is always the diurnal axis + if (field_yaml%has_n_diurnal()) then + dimnames(naxis - 1) = 'time_of_day_'//int2str(field_yaml%get_n_diurnal()) + endif + + !< The last dimension is always the unlimited dimensions + if (.not. this%is_static()) dimnames(naxis) = unlim_dimname + +end subroutine get_dimnames + +!> @brief Wrapper for the register_field call. The select types are needed so that the code can go +!! in the correct interface +subroutine register_field_wrap(fms2io_fileobj, varname, vartype, dimensions) + class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to + character(len=*), INTENT(IN) :: varname !< Name of the variable + character(len=*), INTENT(IN) :: vartype !< The type of the variable + character(len=*), optional, INTENT(IN) :: dimensions(:) !< The dimension names of the field + + select type(fms2io_fileobj) + type is (FmsNetcdfFile_t) + call register_field(fms2io_fileobj, varname, vartype, dimensions) + type is (FmsNetcdfDomainFile_t) + call register_field(fms2io_fileobj, varname, vartype, dimensions) + type is (FmsNetcdfUnstructuredDomainFile_t) + call register_field(fms2io_fileobj, varname, vartype, dimensions) + end select +end subroutine register_field_wrap + +!> @brief Write the field's metadata to the file +subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axis, unlim_dimname, is_regional, & + cell_measures) + class (fmsDiagField_type), target, intent(inout) :: this !< diag field + class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to + integer, intent(in) :: file_id !< File id of the file to write to + integer, intent(in) :: yaml_id !< Yaml id of the yaml entry of this field + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object + character(len=*), intent(in) :: unlim_dimname !< The name of the unlimited dimension + logical, intent(in) :: is_regional !< Flag indicating if the field is regional + character(len=*), intent(in) :: cell_measures !< The cell measures attribute to write + + type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry + character(len=:), allocatable :: var_name !< Variable name + character(len=:), allocatable :: long_name !< Longname to write + character(len=:), allocatable :: units !< Units of the field to write + character(len=120), allocatable :: dimnames(:) !< Dimension names of the field + character(len=120) :: cell_methods!< Cell methods attribute to write + integer :: i !< For do loops + character (len=MAX_STR_LEN), allocatable :: yaml_field_attributes(:,:) !< Variable attributes defined in the yaml + + field_yaml => diag_yaml%get_diag_field_from_id(yaml_id) + var_name = field_yaml%get_var_outname() + + if (allocated(this%axis_ids)) then + call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional) + call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), dimnames) + else + if (this%is_static()) then + call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml)) + else + !< In this case, the scalar variable is a function of time, so we need to pass in the + !! unlimited dimension as a dimension + call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), (/unlim_dimname/)) + endif + endif + + long_name = this%get_longname_to_write(field_yaml) + call register_variable_attribute(fms2io_fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name)) + + units = this%get_units() + if (units .ne. diag_null_string) & + call register_variable_attribute(fms2io_fileobj, var_name, "units", units, str_len=len_trim(units)) + + if (this%has_missing_value()) then + call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", & + this%get_missing_value(field_yaml%get_var_kind())) + call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", & + this%get_missing_value(field_yaml%get_var_kind())) + else + call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", & + get_default_missing_value(field_yaml%get_var_kind())) + call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", & + get_default_missing_value(field_yaml%get_var_kind())) + endif + + if (this%has_data_RANGE()) then + call register_variable_attribute(fms2io_fileobj, var_name, "valid_range", & + this%get_data_range(field_yaml%get_var_kind())) + endif + + if (this%has_interp_method()) then + call register_variable_attribute(fms2io_fileobj, var_name, "interp_method", this%get_interp_method(), & + str_len=len_trim(this%get_interp_method())) + endif + + if (.not. this%static) then + select case (field_yaml%get_var_reduction()) + case (time_average, time_max, time_min, time_diurnal, time_power, time_rms, time_sum) + call register_variable_attribute(fms2io_fileobj, var_name, "time_avg_info", & + trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', & + str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT')) + end select + endif + + cell_methods = "" + !< Check if any of the attributes defined via a "diag_field_add_attribute" call + !! are the cell_methods, if so add to the "cell_methods" variable: + do i = 1, this%num_attributes + call this%attributes(i)%write_metadata(fms2io_fileobj, var_name, & + cell_methods=cell_methods) + enddo + + !< Append the time cell methods based on the variable's reduction + call this%append_time_cell_methods(cell_methods, field_yaml) + if (trim(cell_methods) .ne. "") & + call register_variable_attribute(fms2io_fileobj, var_name, "cell_methods", & + trim(adjustl(cell_methods)), str_len=len_trim(adjustl(cell_methods))) + + !< Write out the cell_measures attribute (i.e Area, Volume) + !! The diag field ids for the Area and Volume are sent in the register call + !! This was defined in file object and passed in here + if (trim(cell_measures) .ne. "") & + call register_variable_attribute(fms2io_fileobj, var_name, "cell_measures", & + trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures))) + + !< Write out the standard_name (this was defined in the register call) + if (this%has_standname()) & + call register_variable_attribute(fms2io_fileobj, var_name, "standard_name", & + trim(this%get_standname()), str_len=len_trim(this%get_standname())) + + call this%write_coordinate_attribute(fms2io_fileobj, var_name, diag_axis) + + if (field_yaml%has_var_attributes()) then + yaml_field_attributes = field_yaml%get_var_attributes() + do i = 1, size(yaml_field_attributes,1) + call register_variable_attribute(fms2io_fileobj, var_name, trim(yaml_field_attributes(i,1)), & + trim(yaml_field_attributes(i,2)), str_len=len_trim(yaml_field_attributes(i,2))) + enddo + deallocate(yaml_field_attributes) + endif +end subroutine write_field_metadata + +!> @brief Writes the coordinate attribute of a field if any of the field's axis has an +!! auxiliary axis +subroutine write_coordinate_attribute (this, fms2io_fileobj, var_name, diag_axis) + CLASS(fmsDiagField_type), intent(in) :: this !< The field object + class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to + character(len=*), intent(in) :: var_name !< Variable name + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object + + integer :: i !< For do loops + character(len = 252) :: aux_coord !< Auxuliary axis name + + !> If the variable is a scalar, go away + if (.not. allocated(this%axis_ids)) return + + !> Determine if any of the field's axis has an auxiliary axis and the + !! axis_names as a variable attribute + aux_coord = "" + do i = 1, size(this%axis_ids) + select type (obj => diag_axis(this%axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + if (obj%has_aux()) then + aux_coord = trim(aux_coord)//" "//obj%get_aux() + endif + end select + enddo + + if (trim(aux_coord) .eq. "") return + + call register_variable_attribute(fms2io_fileobj, var_name, "coordinates", & + trim(adjustl(aux_coord)), str_len=len_trim(adjustl(aux_coord))) + +end subroutine write_coordinate_attribute + +!> @brief Gets a fields data buffer +!! @return a pointer to the data buffer +function get_data_buffer (this) & + result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer + + if (.not. this%data_buffer_is_allocated) & + call mpp_error(FATAL, "The input data buffer for the field:"& + //trim(this%varname)//" was never allocated.") + + rslt => this%input_data_buffer%get_buffer() +end function get_data_buffer + + +!> @brief Gets a fields weight buffer +!! @return a pointer to the weight buffer +function get_weight (this) & + result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + type(real(kind=r8_kind)), pointer :: rslt + + if (.not. this%data_buffer_is_allocated) & + call mpp_error(FATAL, "The input data buffer for the field:"& + //trim(this%varname)//" was never allocated.") + + rslt => this%input_data_buffer%get_weight() +end function get_weight + +!> Gets the flag telling if the math functions need to be done +!! \return Copy of math_needs_to_be_done flag +pure logical function get_math_needs_to_be_done(this) + class (fmsDiagField_type), intent(in) :: this !< diag object + get_math_needs_to_be_done = .false. + if (allocated(this%math_needs_to_be_done)) get_math_needs_to_be_done = this%math_needs_to_be_done +end function get_math_needs_to_be_done +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!! Allocation checks + +!!> @brief Checks if obj%diag_field is allocated +!!! @return true if obj%diag_field is allocated +!logical function has_diag_field (obj) +! class (fmsDiagField_type), intent(in) :: obj !< diag object +! has_diag_field = allocated(obj%diag_field) +!end function has_diag_field +!> @brief Checks if obj%diag_id is allocated +!! @return true if obj%diag_id is allocated +pure logical function has_diag_id (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_diag_id = allocated(this%diag_id) +end function has_diag_id + +!> @brief Checks if obj%metadata is allocated +!! @return true if obj%metadata is allocated +pure logical function has_attributes (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_attributes = this%num_attributes > 0 +end function has_attributes + +!> @brief Checks if obj%static is allocated +!! @return true if obj%static is allocated +pure logical function has_static (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_static = allocated(this%static) +end function has_static + +!> @brief Checks if obj%registered is allocated +!! @return true if obj%registered is allocated +pure logical function has_registered (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_registered = allocated(this%registered) +end function has_registered + +!> @brief Checks if obj%mask_variant is allocated +!! @return true if obj%mask_variant is allocated +pure logical function has_mask_variant (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_mask_variant = allocated(this%mask_variant) +end function has_mask_variant + +!> @brief Checks if obj%local is allocated +!! @return true if obj%local is allocated +pure logical function has_local (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_local = allocated(this%local) +end function has_local + +!> @brief Checks if obj%vartype is allocated +!! @return true if obj%vartype is allocated +pure logical function has_vartype (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_vartype = allocated(this%vartype) +end function has_vartype + +!> @brief Checks if obj%varname is allocated +!! @return true if obj%varname is allocated +pure logical function has_varname (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_varname = allocated(this%varname) +end function has_varname + +!> @brief Checks if obj%longname is allocated +!! @return true if obj%longname is allocated +pure logical function has_longname (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_longname = allocated(this%longname) +end function has_longname + +!> @brief Checks if obj%standname is allocated +!! @return true if obj%standname is allocated +pure logical function has_standname (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_standname = allocated(this%standname) +end function has_standname + +!> @brief Checks if obj%units is allocated +!! @return true if obj%units is allocated +pure logical function has_units (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_units = allocated(this%units) +end function has_units + +!> @brief Checks if obj%modname is allocated +!! @return true if obj%modname is allocated +pure logical function has_modname (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_modname = allocated(this%modname) +end function has_modname + +!> @brief Checks if obj%realm is allocated +!! @return true if obj%realm is allocated +pure logical function has_realm (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_realm = allocated(this%realm) +end function has_realm + +!> @brief Checks if obj%interp_method is allocated +!! @return true if obj%interp_method is allocated +pure logical function has_interp_method (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_interp_method = allocated(this%interp_method) +end function has_interp_method + +!> @brief Checks if obj%frequency is allocated +!! @return true if obj%frequency is allocated +pure logical function has_frequency (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_frequency = allocated(this%frequency) +end function has_frequency + +!> @brief Checks if obj%tile_count is allocated +!! @return true if obj%tile_count is allocated +pure logical function has_tile_count (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_tile_count = allocated(this%tile_count) +end function has_tile_count + +!> @brief Checks if axis_ids of the object is allocated +!! @return true if it is allocated +pure logical function has_axis_ids (this) + class (fmsDiagField_type), intent(in) :: this !< diag field object + has_axis_ids = allocated(this%axis_ids) +end function has_axis_ids + +!> @brief Checks if obj%area is allocated +!! @return true if obj%area is allocated +pure logical function has_area (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_area = allocated(this%area) +end function has_area + +!> @brief Checks if obj%volume is allocated +!! @return true if obj%volume is allocated +pure logical function has_volume (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_volume = allocated(this%volume) +end function has_volume + +!> @brief Checks if obj%missing_value is allocated +!! @return true if obj%missing_value is allocated +pure logical function has_missing_value (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_missing_value = allocated(this%missing_value) +end function has_missing_value + +!> @brief Checks if obj%data_RANGE is allocated +!! @return true if obj%data_RANGE is allocated +pure logical function has_data_RANGE (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_data_RANGE = allocated(this%data_RANGE) +end function has_data_RANGE + +!> @brief Checks if obj%input_data_buffer is allocated +!! @return true if obj%input_data_buffer is allocated +pure logical function has_input_data_buffer (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + has_input_data_buffer = allocated(this%input_data_buffer) +end function has_input_data_buffer + +!> @brief Add a attribute to the diag_obj using the diag_field_id +subroutine diag_field_add_attribute(this, att_name, att_value) + class (fmsDiagField_type), intent (inout) :: this !< The field object + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + this%num_attributes = this%num_attributes + 1 + if (this%num_attributes > max_field_attributes) & + call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"& + //trim(this%varname)//". Increase diag_manager_nml:max_field_attributes.") + + call this%attributes(this%num_attributes)%add(att_name, att_value) +end subroutine diag_field_add_attribute + +!> @brief Determine the default missing value to use based on the requested variable type +!! @return The missing value +function get_default_missing_value(var_type) & + result(rslt) + + integer, intent(in) :: var_type !< The type of the variable to return the missing value as + class(*),allocatable :: rslt + + select case(var_type) + case (r4) + allocate(real(kind=r4_kind) :: rslt) + rslt = real(CMOR_MISSING_VALUE, kind=r4_kind) + case (r8) + allocate(real(kind=r8_kind) :: rslt) + rslt = real(CMOR_MISSING_VALUE, kind=r8_kind) + case default + end select +end function + +!> @brief Determines the diag_obj id corresponding to a module name and field_name +!> @return diag_obj id +PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) & + result(diag_field_id) + CLASS(fmsDiagField_type), INTENT(in) :: this !< The field object + CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable + CHARACTER(len=*), INTENT(in) :: field_name !< Variable name + + integer :: diag_field_id + + diag_field_id = DIAG_FIELD_NOT_FOUND + if (this%get_varname() .eq. trim(field_name) .and. & + this%get_modname() .eq. trim(module_name)) then + diag_field_id = this%get_id() + endif +end function diag_field_id_from_name + +!> @brief Adds the area and volume id to a field object +subroutine add_area_volume(this, area, volume) + CLASS(fmsDiagField_type), intent(inout) :: this !< The field object + INTEGER, optional, INTENT(in) :: area !< diag ids of area + INTEGER, optional, INTENT(in) :: volume !< diag ids of volume + + if (present(area)) then + if (area > 0) then + this%area = area + else + call mpp_error(FATAL, "diag_field_add_cell_measures: the area id is not valid. "& + &"Verify that the area_id passed in to the field:"//this%varname//& + &" is valid and that the field is registered and in the diag_table.yaml") + endif + endif + + if (present(volume)) then + if (volume > 0) then + this%volume = volume + else + call mpp_error(FATAL, "diag_field_add_cell_measures: the volume id is not valid. "& + &"Verify that the volume_id passed in to the field:"//this%varname//& + &" is valid and that the field is registered and in the diag_table.yaml") + endif + endif + +end subroutine add_area_volume + +!> @brief Append the time cell meathods based on the variable's reduction +subroutine append_time_cell_methods(this, cell_methods, field_yaml) + class (fmsDiagField_type), target, intent(inout) :: this !< diag field + character(len=*), intent(inout) :: cell_methods !< The cell methods var to append to + type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The field's yaml + + if (this%static) then + cell_methods = trim(cell_methods)//" time: point " + return + endif + + select case (field_yaml%get_var_reduction()) + case (time_none) + cell_methods = trim(cell_methods)//" time: point " + case (time_diurnal) + cell_methods = trim(cell_methods)//" time: mean" + case (time_power) + cell_methods = trim(cell_methods)//" time: mean_pow"//int2str(field_yaml%get_pow_value()) + case (time_rms) + cell_methods = trim(cell_methods)//" time: root_mean_square" + case (time_max) + cell_methods = trim(cell_methods)//" time: max" + case (time_min) + cell_methods = trim(cell_methods)//" time: min" + case (time_average) + cell_methods = trim(cell_methods)//" time: mean" + case (time_sum) + cell_methods = trim(cell_methods)//" time: sum" + end select +end subroutine append_time_cell_methods + +!> Dumps any data from a given fmsDiagField_type object +subroutine dump_field_obj (this, unit_num) + class(fmsDiagField_type), intent(in) :: this + integer, intent(in) :: unit_num !< passed in from dump_diag_obj if log file is being written to + integer :: i + + if( mpp_pe() .eq. mpp_root_pe()) then + if( allocated(this%file_ids)) write(unit_num, *) 'file_ids:' ,this%file_ids + if( allocated(this%diag_id)) write(unit_num, *) 'diag_id:' ,this%diag_id + if( allocated(this%static)) write(unit_num, *) 'static:' ,this%static + if( allocated(this%registered)) write(unit_num, *) 'registered:' ,this%registered + if( allocated(this%mask_variant)) write(unit_num, *) 'mask_variant:' ,this%mask_variant + if( allocated(this%do_not_log)) write(unit_num, *) 'do_not_log:' ,this%do_not_log + if( allocated(this%local)) write(unit_num, *) 'local:' ,this%local + if( allocated(this%vartype)) write(unit_num, *) 'vartype:' ,this%vartype + if( allocated(this%varname)) write(unit_num, *) 'varname:' ,this%varname + if( allocated(this%longname)) write(unit_num, *) 'longname:' ,this%longname + if( allocated(this%standname)) write(unit_num, *) 'standname:' ,this%standname + if( allocated(this%units)) write(unit_num, *) 'units:' ,this%units + if( allocated(this%modname)) write(unit_num, *) 'modname:' ,this%modname + if( allocated(this%realm)) write(unit_num, *) 'realm:' ,this%realm + if( allocated(this%interp_method)) write(unit_num, *) 'interp_method:' ,this%interp_method + if( allocated(this%tile_count)) write(unit_num, *) 'tile_count:' ,this%tile_count + if( allocated(this%axis_ids)) write(unit_num, *) 'axis_ids:' ,this%axis_ids + write(unit_num, *) 'type_of_domain:' ,this%type_of_domain + if( allocated(this%area)) write(unit_num, *) 'area:' ,this%area + if( allocated(this%missing_value)) then + select type(missing_val => this%missing_value) + type is (real(r4_kind)) + write(unit_num, *) 'missing_value:', missing_val + type is (real(r8_kind)) + write(unit_num, *) 'missing_value:' ,missing_val + type is(integer(i4_kind)) + write(unit_num, *) 'missing_value:' ,missing_val + type is(integer(i8_kind)) + write(unit_num, *) 'missing_value:' ,missing_val + end select + endif + if( allocated( this%data_RANGE)) then + select type(drange => this%data_RANGE) + type is (real(r4_kind)) + write(unit_num, *) 'data_RANGE:' ,drange + type is (real(r8_kind)) + write(unit_num, *) 'data_RANGE:' ,drange + type is(integer(i4_kind)) + write(unit_num, *) 'data_RANGE:' ,drange + type is(integer(i8_kind)) + write(unit_num, *) 'data_RANGE:' ,drange + end select + endif + write(unit_num, *) 'num_attributes:' ,this%num_attributes + if( allocated(this%attributes)) then + do i=1, this%num_attributes + if( allocated(this%attributes(i)%att_value)) then + select type( val => this%attributes(i)%att_value) + type is (real(r8_kind)) + write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val + type is (real(r4_kind)) + write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val + type is (integer(i4_kind)) + write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val + type is (integer(i8_kind)) + write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val + end select + endif + enddo + endif + + endif + +end subroutine + +!< @brief Get the starting compute domain indices for a set of axis +!! @return compute domain starting indices +function get_starting_compute_domain(axis_ids, diag_axis) & +result(compute_domain) + integer, intent(in) :: axis_ids(:) !< Array of axis ids + class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of axis object + + integer :: compute_domain(4) + integer :: a !< For looping through axes + integer :: compute_idx(2) !< Compute domain indices (starting, ending) + logical :: dummy !< Dummy variable for the `get_compute_domain` subroutine + + compute_domain = 1 + axis_loop: do a = 1,size(axis_ids) + select type (axis => diag_axis(axis_ids(a))%axis) + type is (fmsDiagFullAxis_type) + call axis%get_compute_domain(compute_idx, dummy) + if ( compute_idx(1) .ne. diag_null) compute_domain(a) = compute_idx(1) + end select + enddo axis_loop +end function get_starting_compute_domain + +!> Get list of field ids +pure function get_file_ids(this) + class(fmsDiagField_type), intent(in) :: this + integer, allocatable :: get_file_ids(:) !< Ids of the FMS_diag_files the variable + get_file_ids = this%file_ids +end function + +!> @brief Get the mask from the input buffer object +!! @return a pointer to the mask +function get_mask(this) + class(fmsDiagField_type), target, intent(in) :: this !< input buffer object + logical, pointer :: get_mask(:,:,:,:) + get_mask => this%mask +end function get_mask + +!> @brief If in openmp region, omp_axis should be provided in order to allocate to the given axis lengths. +!! Otherwise mask will be allocated to the size of mask_in +subroutine allocate_mask(this, mask_in, omp_axis) + class(fmsDiagField_type), target, intent(inout) :: this !< input buffer object + logical, intent(in) :: mask_in(:,:,:,:) + class(fmsDiagAxisContainer_type), intent(in), optional :: omp_axis(:) !< true if calling from omp region + integer :: axis_num, length(4) + integer, pointer :: id_num + if(allocated(this%mask)) then + call mpp_error(NOTE,"set_mask:: mask already allocated for field"//this%longname) + deallocate(this%mask) + endif + ! if not omp just allocate to whatever is given + if(.not. present(omp_axis)) then + allocate(this%mask(size(mask_in,1), size(mask_in,2), size(mask_in,3), & + size(mask_in,4))) + ! otherwise loop through axis and get sizes + else + length = 1 + do axis_num=1, size(this%axis_ids) + id_num => this%axis_ids(axis_num) + select type(axis => omp_axis(id_num)%axis) + type is (fmsDiagFullAxis_type) + length(axis_num) = axis%axis_length() + end select + enddo + allocate(this%mask(length(1), length(2), length(3), length(4))) + endif +end subroutine allocate_mask + +!> Sets previously allocated mask to mask_in at given index ranges +subroutine set_mask(this, mask_in, is, js, ks, ie, je, ke) + class(fmsDiagField_type), intent(inout) :: this + logical, intent(in) :: mask_in(:,:,:,:) + integer, optional, intent(in) :: is, js, ks, ie, je, ke + if(present(is)) then + if(is .lt. lbound(this%mask,1) .or. ie .gt. ubound(this%mask,1) .or. & + js .lt. lbound(this%mask,2) .or. je .gt. ubound(this%mask,2) .or. & + ks .lt. lbound(this%mask,3) .or. ke .gt. ubound(this%mask,3)) then + print *, mpp_pe(), "alloc'd", SHAPE(this%mask), "passed:", is,ie,js,je,ks,ke + call mpp_error(FATAL,"set_mask:: given indices out of bounds for allocated mask") + endif + this%mask(is:ie, js:je, ks:ke, :) = mask_in + else + this%mask = mask_in + endif +end subroutine set_mask + +#endif +end module fms_diag_field_object_mod diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 new file mode 100644 index 0000000000..687f609252 --- /dev/null +++ b/diag_manager/fms_diag_file_object.F90 @@ -0,0 +1,1479 @@ +!*********************************************************************** +!* 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_output_yaml_mod fms_diag_output_yaml_mod +!> @ingroup diag_manager +!! @brief fms_diag_file_object_mod handles the file objects data, functions, and subroutines. +!! @author Tom Robinson +!! @description The fmsDiagFile_type contains the information for each history file to be written. It has +!! a pointer to the information from the diag yaml, additional metadata that comes from the model, and a +!! list of the variables and their variable IDs that are in the file. +module fms_diag_file_object_mod +#ifdef use_yaml +use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t, & + get_instance_filename, open_file, close_file, get_mosaic_tile_file, unlimited, & + register_axis, register_field, register_variable_attribute, write_data, & + dimension_exists, register_global_attribute +use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, & + TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, & + get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, & + get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, & + time_diurnal, time_power, time_none, avg_name, no_units, pack_size_str, & + middle_time, begin_time, end_time, MAX_STR_LEN +use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, & + VALID_CALENDAR_TYPES, operator(>=), date_to_string, & + OPERATOR(/), OPERATOR(+), operator(<) +use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string, get_date_dif +use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type +use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, & + fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, & + fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, & + fmsDiagDiurnalAxis_type, create_new_z_subaxis +use fms_diag_field_object_mod, only: fmsDiagField_type +use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type +use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, & + uppercase, lowercase + +implicit none +private + +public :: fmsDiagFileContainer_type +public :: fmsDiagFile_type, fms_diag_files_object_init, fms_diag_files_object_initialized + +logical :: fms_diag_files_object_initialized = .false. + +integer, parameter :: var_string_len = 25 + +type :: fmsDiagFile_type + private + integer :: id !< The number associated with this file in the larger array of files + TYPE(time_type) :: start_time !< The start time for the file + TYPE(time_type) :: last_output !< Time of the last time output was writen + TYPE(time_type) :: next_output !< Time of the next write + TYPE(time_type) :: next_next_output !< Time of the next next write + TYPE(time_type) :: no_more_data !< Time to stop receiving data for this file + logical :: done_writing_data!< .True. if finished writing data + + !< This will be used when using the new_file_freq keys in the diag_table.yaml + TYPE(time_type) :: next_close !< Time to close the file + logical :: is_file_open !< .True. if the file is opened + + class(FmsNetcdfFile_t), allocatable :: fms2io_fileobj !< fms2_io file object for this history file + type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data + integer :: type_of_domain !< The type of domain to use to open the file + !! NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, SUB_REGIONAL + class(diagDomain_t), pointer :: domain !< The domain to use, + !! null if NO_DOMAIN or SUB_REGIONAL + character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from + !! the model. + integer, dimension(:), allocatable :: field_ids !< Variable IDs corresponding to file_varlist + integer, dimension(:), allocatable :: yaml_ids !< IDs corresponding to the yaml field section + logical, dimension(:), private, allocatable :: field_registered !< Array corresponding to `field_ids`, .true. + !! if the variable has been registered and + !! `field_id` has been set for the variable + integer, allocatable :: num_registered_fields !< The number of fields registered + !! to the file + integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file + integer :: number_of_axis !< Number of axis in the file + integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file + integer :: number_of_buffers !< Number of buffers that have been added to the file + logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum + integer :: unlim_dimension_level !< The unlimited dimension level currently being written + logical :: is_static !< .True. if the frequency is -1 + + contains + procedure, public :: add_field_and_yaml_id + procedure, public :: add_buffer_id + procedure, public :: is_field_registered + procedure, public :: init_diurnal_axis + procedure, public :: has_file_metadata_from_model + procedure, public :: has_fileobj + procedure, public :: has_diag_yaml_file + procedure, public :: set_domain_from_axis + procedure, public :: set_file_domain + procedure, public :: add_axes + procedure, public :: add_start_time + procedure, public :: set_file_time_ops + procedure, public :: has_field_ids + procedure, public :: get_id +! TODO procedure, public :: get_fileobj ! TODO +! TODO procedure, public :: get_diag_yaml_file ! TODO + procedure, public :: get_file_metadata_from_model + procedure, public :: get_field_ids +! The following fuctions come will use the yaml inquiry functions + procedure, public :: get_file_fname + procedure, public :: get_file_frequnit + procedure, public :: get_file_freq + procedure, public :: get_file_timeunit + procedure, public :: get_file_unlimdim + procedure, public :: get_file_sub_region + procedure, public :: get_file_new_file_freq + procedure, public :: get_filename_time + procedure, public :: get_file_new_file_freq_units + procedure, public :: get_file_start_time + procedure, public :: get_file_duration + procedure, public :: get_file_duration_units + procedure, public :: get_file_varlist + procedure, public :: get_file_global_meta + procedure, public :: is_done_writing_data + procedure, public :: has_file_fname + procedure, public :: has_file_frequnit + procedure, public :: has_file_freq + procedure, public :: has_file_timeunit + procedure, public :: has_file_unlimdim + procedure, public :: has_file_sub_region + procedure, public :: has_file_new_file_freq + procedure, public :: has_file_new_file_freq_units + procedure, public :: has_file_start_time + procedure, public :: has_file_duration + procedure, public :: has_file_duration_units + procedure, public :: has_file_varlist + procedure, public :: has_file_global_meta + procedure, public :: dump_file_obj +end type fmsDiagFile_type + +type, extends (fmsDiagFile_type) :: subRegionalFile_type + integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file + logical :: write_on_this_pe !< Flag indicating if the subregion is on the current PE + logical :: is_subaxis_defined !< Flag indicating if the subaxes have already been defined +end type subRegionalFile_type + +!> \brief A container for fmsDiagFile_type. This is used to create the array of files +type fmsDiagFileContainer_type + class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object + + contains + procedure :: is_regional + procedure :: is_file_static + procedure :: open_diag_file + procedure :: write_global_metadata + procedure :: write_time_metadata + procedure :: write_field_data + procedure :: write_axis_metadata + procedure :: write_field_metadata + procedure :: write_axis_data + procedure :: writing_on_this_pe + procedure :: is_time_to_write + procedure :: is_time_to_close_file + procedure :: write_time_data + procedure :: update_next_write + procedure :: update_current_new_file_freq_index + procedure :: increase_unlim_dimension_level + procedure :: get_unlim_dimension_level + procedure :: close_diag_file +end type fmsDiagFileContainer_type + +!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files +!class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_file + +contains + +!< @brief Allocates the number of files and sets an ID based for each file +!! @return true if there are files allocated in the YAML object +logical function fms_diag_files_object_init (files_array) + class(fmsDiagFileContainer_type), allocatable, target, intent(inout) :: files_array (:) !< array of diag files + class(fmsDiagFile_type), pointer :: obj => null() !< Pointer for each member of the array + integer :: nFiles !< Number of files in the diag yaml + integer :: i !< Looping iterator + if (diag_yaml%has_diag_files()) then + nFiles = diag_yaml%size_diag_files() + allocate (files_array(nFiles)) + set_ids_loop: do i= 1,nFiles + !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array. + !! This will be set in a add_axes + if (diag_yaml%diag_files(i)%has_file_sub_region()) then + allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file) + obj => files_array(i)%FMS_diag_file + select type (obj) + type is (subRegionalFile_type) + allocate(obj%sub_axis_ids(max_axes)) + obj%sub_axis_ids = diag_null + obj%write_on_this_pe = .false. + obj%is_subaxis_defined = .false. + obj%number_of_axis = 0 + end select + else + allocate(FmsDiagFile_type::files_array(i)%FMS_diag_file) + obj => files_array(i)%FMS_diag_file + endif + !! + obj%diag_yaml_file => diag_yaml%diag_files(i) + obj%id = i + allocate(obj%field_ids(diag_yaml%diag_files(i)%size_file_varlist())) + allocate(obj%buffer_ids(diag_yaml%diag_files(i)%size_file_varlist())) + allocate(obj%yaml_ids(diag_yaml%diag_files(i)%size_file_varlist())) + allocate(obj%field_registered(diag_yaml%diag_files(i)%size_file_varlist())) + !! Initialize the integer arrays + obj%field_ids = DIAG_NOT_REGISTERED + obj%yaml_ids = DIAG_NOT_REGISTERED + obj%buffer_ids = DIAG_NOT_REGISTERED + obj%field_registered = .FALSE. + obj%num_registered_fields = 0 + obj%number_of_buffers = 0 + + !> These will be set in a set_file_domain + obj%type_of_domain = NO_DOMAIN + obj%domain => null() + + !> This will be set in a add_axes + allocate(obj%axis_ids(max_axes)) + obj%number_of_axis = 0 + + !> Set the start_time of the file to the base_time and set up the *_output variables + obj%done_writing_data = .false. + obj%start_time = get_base_time() + obj%last_output = get_base_time() + obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit()) + obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit()) + + if (obj%has_file_new_file_freq()) then + obj%next_close = diag_time_inc(obj%start_time, obj%get_file_new_file_freq(), & + obj%get_file_new_file_freq_units()) + else + obj%next_close = diag_time_inc(obj%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + endif + obj%is_file_open = .false. + + if(obj%has_file_duration()) then + obj%no_more_data = diag_time_inc(obj%start_time, obj%get_file_duration(), & + obj%get_file_duration_units()) + else + obj%no_more_data = diag_time_inc(obj%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + endif + + obj%time_ops = .false. + obj%unlim_dimension_level = 0 + obj%is_static = obj%get_file_freq() .eq. -1 + + nullify(obj) + enddo set_ids_loop + fms_diag_files_object_init = .true. + else + fms_diag_files_object_init = .false. +! mpp_error("fms_diag_files_object_init: The diag_table.yaml file has not been correctly parsed.",& +! FATAL) + endif +end function fms_diag_files_object_init + +!< @brief Determine if the field corresponding to the field_id was registered to the file +!! @return .True. if the field was registed to the file +pure logical function is_field_registered(this, field_id) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer, intent(in) :: field_id !< Id of the field to check + + is_field_registered = this%field_registered(field_id) +end function is_field_registered + +!> \brief Adds a field and yaml ID to the file +subroutine add_field_and_yaml_id (this, new_field_id, yaml_id) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + integer, intent(in) :: new_field_id !< The field ID to be added to field_ids + integer, intent(in) :: yaml_id !< The yaml_id + + this%num_registered_fields = this%num_registered_fields + 1 + if (this%num_registered_fields .le. size(this%field_ids)) then + this%field_ids( this%num_registered_fields ) = new_field_id + this%yaml_ids( this%num_registered_fields ) = yaml_id + this%field_registered( this%num_registered_fields ) = .true. + else + call mpp_error(FATAL, "The file: "//this%get_file_fname()//" has already been assigned its maximum "//& + "number of fields.") + endif +end subroutine add_field_and_yaml_id + +!> \brief Adds a buffer_id to the file object +subroutine add_buffer_id (this, buffer_id) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + integer, intent(in) :: buffer_id !< Buffer id to add to the file + + this%number_of_buffers = this%number_of_buffers + 1 + this%buffer_ids(this%number_of_buffers) = buffer_id + +end subroutine add_buffer_id + +!> \brief Initializes a diurnal axis for a fileobj +!! \note This is going to be called for every variable in the file, if the variable is not a diurnal variable +!! it will do nothing. It only defined a diurnal axis once. +subroutine init_diurnal_axis(this, diag_axis, naxis, yaml_id) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Array of diag_axis object + integer, intent(inout) :: naxis !< Number of diag_axis that heve been defined + integer, intent(in) :: yaml_id !< The ID to the variable's yaml + + integer :: i !< For do loops + type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry + + field_yaml => diag_yaml%get_diag_field_from_id(yaml_id) + + !< Go away if the file does not need a diurnal axis + if (.not. field_yaml%has_n_diurnal()) return + + !< Check if the diurnal axis is already defined for this number of diurnal samples + do i = 1, this%number_of_axis + select type(axis=>diag_axis(this%axis_ids(i))%axis) + type is (fmsDiagDiurnalAxis_type) + if(field_yaml%get_n_diurnal() .eq. axis%get_diurnal_axis_samples()) return + end select + end do + + !< If it is not already defined, define it + call define_diurnal_axis(diag_axis, naxis, field_yaml%get_n_diurnal(), .true.) + call define_diurnal_axis(diag_axis, naxis, field_yaml%get_n_diurnal(), .False.) + + !< Add it to the list of axis for the file + this%number_of_axis = this%number_of_axis + 1 + this%axis_ids(this%number_of_axis) = naxis !< This is the diurnal axis edges + + this%number_of_axis = this%number_of_axis + 1 + this%axis_ids(this%number_of_axis) = naxis - 1 !< This the diurnal axis + +end subroutine init_diurnal_axis + +!> \brief Set the time_ops variable in the diag_file object +subroutine set_file_time_ops(this, VarYaml, is_static) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + type (diagYamlFilesVar_type), intent(in) :: VarYaml !< The variable's yaml file + logical, intent(in) :: is_static !< Flag indicating if variable is static + + !< Go away if the file is static + if (this%is_static) return + + if (this%time_ops) then + if (is_static) return + if (VarYaml%get_var_reduction() .eq. time_none) then + call mpp_error(FATAL, "The file: "//this%get_file_fname()//& + " has variables that are time averaged and instantaneous") + endif + else + select case (VarYaml%get_var_reduction()) + case (time_average, time_rms, time_max, time_min, time_sum, time_diurnal, time_power) + this%time_ops = .true. + end select + endif + +end subroutine set_file_time_ops + +!> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated +!! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set +pure logical function has_file_metadata_from_model (this) + class(fmsDiagFile_type), intent(in) :: this !< The file object + has_file_metadata_from_model = allocated(this%file_metadata_from_model) +end function has_file_metadata_from_model + +!> \brief Logical function to determine if the variable fileobj has been allocated or associated +!! \return .True. if fileobj exists .False. if fileobj has not been set +pure logical function has_fileobj (this) + class(fmsDiagFile_type), intent(in) :: this !< The file object + has_fileobj = allocated(this%fms2io_fileobj) +end function has_fileobj + +!> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated +!! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set +pure logical function has_diag_yaml_file (this) + class(fmsDiagFile_type), intent(in) :: this !< The file object + has_diag_yaml_file = associated(this%diag_yaml_file) +end function has_diag_yaml_file + +!> \brief Get the time to use to determine the filename, if using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr) +!! \return The time to use when determining the filename +function get_filename_time(this) & + result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + type(time_type) :: res + + select case (this%diag_yaml_file%get_filename_time()) + case (begin_time) + res = this%last_output + case (middle_time) + res = (this%last_output + this%next_close)/2 + case (end_time) + res = this%next_close + end select +end function get_filename_time + +!> \brief Logical function to determine if the variable field_ids has been allocated or associated +!! \return .True. if field_ids exists .False. if field_ids has not been set +pure logical function has_field_ids (this) + class(fmsDiagFile_type), intent(in) :: this !< The file object + has_field_ids = allocated(this%field_ids) +end function has_field_ids + +!> \brief Returns a copy of the value of id +!! \return A copy of id +pure function get_id (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%id +end function get_id + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! TODO +!> \brief Returns a copy of the value of fileobj +!! \return A copy of fileobj +!pure function get_fileobj (obj) result (res) +! class(fmsDiagFile_type), intent(in) :: obj !< The file object +! class(FmsNetcdfFile_t) :: res +! res = obj%fileobj +!end function get_fileobj +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! TODO +!!> \brief Returns a copy of the value of diag_yaml_file +!!! \return A copy of diag_yaml_file +!pure function get_diag_yaml_file (obj) result (res) +! class(fmsDiagFile_type), intent(in) :: obj !< The file object +! type(diagYamlFiles_type) :: res +! res = obj%diag_yaml_file +!end function get_diag_yaml_file + +!> \brief Returns a copy of the value of file_metadata_from_model +!! \return A copy of file_metadata_from_model +pure function get_file_metadata_from_model (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character(len=:), dimension(:), allocatable :: res + res = this%file_metadata_from_model +end function get_file_metadata_from_model + +!> \brief Returns a copy of the value of field_ids +!! \return A copy of field_ids +pure function get_field_ids (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer, dimension(:), allocatable :: res + allocate(res(size(this%field_ids))) + res = this%field_ids +end function get_field_ids + +!!!!!!!!! Functions from diag_yaml_file +!> \brief Returns a copy of file_fname from the yaml object +!! \return Copy of file_fname +pure function get_file_fname (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + res = this%diag_yaml_file%get_file_fname() +end function get_file_fname + +!> \brief Returns a copy of file_frequnit from the yaml object +!! \return Copy of file_frequnit +pure function get_file_frequnit (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_frequnit() +end function get_file_frequnit + +!> \brief Returns a copy of file_freq from the yaml object +!! \return Copy of file_freq +pure function get_file_freq (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_freq() +end function get_file_freq + +!> \brief Returns a copy of file_timeunit from the yaml object +!! \return Copy of file_timeunit +pure function get_file_timeunit (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_timeunit() +end function get_file_timeunit + +!> \brief Returns a copy of file_unlimdim from the yaml object +!! \return Copy of file_unlimdim +pure function get_file_unlimdim (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + res = this%diag_yaml_file%get_file_unlimdim() +end function get_file_unlimdim + +!> \brief Returns a copy of file_sub_region from the yaml object +!! \return Copy of file_sub_region +function get_file_sub_region (obj) result(res) + class(fmsDiagFile_type), intent(in) :: obj !< The file object + type(subRegion_type) :: res + res = obj%diag_yaml_file%get_file_sub_region() +end function get_file_sub_region + +!> \brief Returns a copy of file_new_file_freq from the yaml object +!! \return Copy of file_new_file_freq +pure function get_file_new_file_freq (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_new_file_freq() +end function get_file_new_file_freq + +!> \brief Returns a copy of file_new_file_freq_units from the yaml object +!! \return Copy of file_new_file_freq_units +pure function get_file_new_file_freq_units (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_new_file_freq_units() +end function get_file_new_file_freq_units + +!> \brief Returns a copy of file_start_time from the yaml object +!! \return Copy of file_start_time +pure function get_file_start_time (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + res = this%diag_yaml_file%get_file_start_time() +end function get_file_start_time + +!> \brief Returns a copy of file_duration from the yaml object +!! \return Copy of file_duration +pure function get_file_duration (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_duration() +end function get_file_duration + +!> \brief Returns a copy of file_duration_units from the yaml object +!! \return Copy of file_duration_units +pure function get_file_duration_units (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%diag_yaml_file%get_file_duration_units() +end function get_file_duration_units + +!> \brief Returns a copy of file_varlist from the yaml object +!! \return Copy of file_varlist +pure function get_file_varlist (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable, dimension(:) :: res + res = this%diag_yaml_file%get_file_varlist() +end function get_file_varlist + +!> \brief Returns a copy of file_global_meta from the yaml object +!! \return Copy of file_global_meta +pure function get_file_global_meta (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=MAX_STR_LEN), allocatable, dimension(:,:) :: res + res = this%diag_yaml_file%get_file_global_meta() +end function get_file_global_meta + +!> \brief Determines if done writing data +!! \return .True. if done writing data +pure function is_done_writing_data (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%done_writing_data +end function is_done_writing_data + +!> \brief Checks if file_fname is allocated in the yaml object +!! \return true if file_fname is allocated +pure function has_file_fname (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_fname() +end function has_file_fname + +!> \brief Checks if file_frequnit is allocated in the yaml object +!! \return true if file_frequnit is allocated +pure function has_file_frequnit (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_frequnit() +end function has_file_frequnit + +!> \brief Checks if file_freq is allocated in the yaml object +!! \return true if file_freq is allocated +pure function has_file_freq (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_freq() +end function has_file_freq + +!> \brief Checks if file_timeunit is allocated in the yaml object +!! \return true if file_timeunit is allocated +pure function has_file_timeunit (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_timeunit() +end function has_file_timeunit + +!> \brief Checks if file_unlimdim is allocated in the yaml object +!! \return true if file_unlimdim is allocated +pure function has_file_unlimdim (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_unlimdim() +end function has_file_unlimdim + +!> \brief Checks if file_sub_region is allocated in the yaml object +!! \return true if file_sub_region is allocated +pure function has_file_sub_region (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_sub_region() +end function has_file_sub_region + +!> \brief Checks if file_new_file_freq is allocated in the yaml object +!! \return true if file_new_file_freq is allocated +pure function has_file_new_file_freq (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_new_file_freq() +end function has_file_new_file_freq + +!> \brief Checks if file_new_file_freq_units is allocated in the yaml object +!! \return true if file_new_file_freq_units is allocated +pure function has_file_new_file_freq_units (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_new_file_freq_units() +end function has_file_new_file_freq_units + +!> \brief Checks if file_start_time is allocated in the yaml object +!! \return true if file_start_time is allocated +pure function has_file_start_time (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_start_time() +end function has_file_start_time + +!> \brief Checks if file_duration is allocated in the yaml object +!! \return true if file_duration is allocated +pure function has_file_duration (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_duration() +end function has_file_duration + +!> \brief Checks if file_duration_units is allocated in the yaml object +!! \return true if file_duration_units is allocated +pure function has_file_duration_units (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_duration_units() +end function has_file_duration_units + +!> \brief Checks if file_varlist is allocated in the yaml object +!! \return true if file_varlist is allocated +pure function has_file_varlist (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_varlist() +end function has_file_varlist + +!> \brief Checks if file_global_meta is allocated in the yaml object +!! \return true if file_global_meta is allocated +pure function has_file_global_meta (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + res = this%diag_yaml_file%has_file_global_meta() +end function has_file_global_meta + +!> @brief Sets the domain and type of domain from the axis IDs +subroutine set_domain_from_axis(this, diag_axis, axes) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of diag_axis + integer, intent(in) :: axes (:) + + call get_domain_and_domain_type(diag_axis, axes, this%type_of_domain, this%domain, this%get_file_fname()) +end subroutine set_domain_from_axis + +!> @brief Set the domain and the type_of_domain for a file +!> @details This subroutine is going to be called once by every variable in the file +!! in register_diag_field. It will update the domain and the type_of_domain if needed and verify that +!! all the variables are in the same domain +subroutine set_file_domain(this, domain, type_of_domain) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + integer, INTENT(in) :: type_of_domain !< fileobj_type to use + CLASS(diagDomain_t), INTENT(in), target :: domain !< Domain + + if (type_of_domain .ne. this%type_of_domain) then + !! If the current type_of_domain in the file obj is not the same as the variable calling this subroutine + + if (type_of_domain .eq. NO_DOMAIN .or. this%type_of_domain .eq. NO_DOMAIN) then + !! If they are not the same then one of them can be NO_DOMAIN + !! (i.e a file can have variables that are not domain decomposed and variables that are) + + if (type_of_domain .ne. NO_DOMAIN) then + !! Update the file's type_of_domain and domain if needed + this%type_of_domain = type_of_domain + this%domain => domain + endif + + else + !! If they are not the same and of them is not NO_DOMAIN, then crash because the variables don't have the + !! same domain (i.e a file has a variable is that in a 2D domain and one that is in a UG domain) + + call mpp_error(FATAL, "The file: "//this%get_file_fname()//" has variables that are not in the same domain") + endif + endif + +end subroutine set_file_domain + +!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist +subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output_buffers) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids + class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object + integer, intent(inout) :: naxis !< Number of axis that have been + !! registered + integer, intent(in) :: yaml_id !< Yaml id of the field section for + !! this var + integer, intent(in) :: buffer_id !< ID of the buffer + type(fmsDiagOutputBuffer_type), intent(inout) :: output_buffers(:) !< Array of output buffers + + type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry + + integer :: i, j !< For do loops + logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere + logical :: axis_found !< Flag indicating that the axis was already to the file obj + integer, allocatable :: var_axis_ids(:) !< Array of the variable's axis ids + + is_cube_sphere = .false. + + field_yaml => diag_yaml%get_diag_field_from_id(yaml_id) + !< Created a copy here, because if the variable has a z subaxis var_axis_ids will be modified in + !! `create_new_z_subaxis` to contain the id of the new z subaxis instead of the parent axis, + !! which will be added to the the list of axis in the file object (axis_ids is intent(in), + !! which is why the copy was needed) + var_axis_ids = axis_ids + + if (field_yaml%has_var_zbounds()) then + call create_new_z_subaxis(field_yaml%get_var_zbounds(), var_axis_ids, diag_axis, naxis, & + this%axis_ids, this%number_of_axis) + endif + + select type(this) + type is (subRegionalFile_type) + if (.not. this%is_subaxis_defined) then + if (associated(this%domain)) then + if (this%domain%get_ntiles() .eq. 6) is_cube_sphere = .true. + endif + + call define_subaxis(diag_axis, var_axis_ids, naxis, this%get_file_sub_region(), & + is_cube_sphere, this%write_on_this_pe) + this%is_subaxis_defined = .true. + + !> add the axis to the list of axis in the file + if (this%write_on_this_pe) then + do i = 1, size(var_axis_ids) + this%number_of_axis = this%number_of_axis + 1 !< This is the current number of axis in the file + this%axis_ids(this%number_of_axis) = diag_axis(var_axis_ids(i))%axis%get_subaxes_id() + + !< Change the variable axis ids to the subaxis that was just created + var_axis_ids(i) = this%axis_ids(this%number_of_axis) + enddo + else + this%axis_ids = diag_null + endif + endif + type is (fmsDiagFile_type) + do i = 1, size(var_axis_ids) + axis_found = .false. + do j = 1, this%number_of_axis + !> Check if the axis already exists, move on + if (var_axis_ids(i) .eq. this%axis_ids(j)) then + axis_found = .true. + cycle + endif + enddo + + if (.not. axis_found) then + !> If the axis does not exist add it to the list + this%number_of_axis = this%number_of_axis + 1 + this%axis_ids(this%number_of_axis) = var_axis_ids(i) + endif + enddo + end select + + !> Add the axis to the buffer object + call output_buffers(buffer_id)%add_axis_ids(var_axis_ids) +end subroutine add_axes + +!> @brief adds the start time to the fileobj +!! @note This should be called from the register field calls. It can be called multiple times (one for each variable) +!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time +subroutine add_start_time(this, start_time, model_time) + class(fmsDiagFile_type), intent(inout) :: this !< The file object + TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj + TYPE(time_type), intent(out) :: model_time !< The current model time + !! this will be set to the start_time + !! at the begining of the run + + !< If the start_time sent in is equal to the base_time return because + !! this%start_time was already set to the base_time + if (start_time .eq. get_base_time()) return + + if (this%start_time .ne. get_base_time()) then + !> If the this%start_time is not equal to the base_time from the diag_table + !! this%start_time was already updated so make sure it is the same or error out + if (this%start_time .ne. start_time)& + call mpp_error(FATAL, "The variables associated with the file:"//this%get_file_fname()//" have"& + &" different start_time") + else + !> If the this%start_time is equal to the base_time, + !! simply update it with the start_time and set up the *_output variables + model_time = start_time + this%start_time = start_time + this%last_output = start_time + this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit()) + this%next_next_output = diag_time_inc(this%next_output, this%get_file_freq(), this%get_file_frequnit()) + if (this%has_file_new_file_freq()) then + this%next_close = diag_time_inc(this%start_time, this%get_file_new_file_freq(), & + this%get_file_new_file_freq_units()) + else + this%next_close = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + endif + + if(this%has_file_duration()) then + this%no_more_data = diag_time_inc(this%start_time, this%get_file_duration(), & + this%get_file_duration_units()) + else + this%no_more_data = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + endif + + endif + +end subroutine + +!> writes out internal values for fmsDiagFile_type object +subroutine dump_file_obj(this, unit_num) + class(fmsDiagFile_type), intent(in) :: this !< the file object + integer, intent(in) :: unit_num !< passed in from dump_diag_obj + !! will either be for new log file or stdout + write( unit_num, *) 'file id:', this%id + write( unit_num, *) 'start time:', date_to_string(this%start_time) + write( unit_num, *) 'last_output', date_to_string(this%last_output) + write( unit_num, *) 'next_output', date_to_string(this%next_output) + write( unit_num, *)'next_next_output', date_to_string(this%next_next_output) + write( unit_num, *)'next_close', date_to_string(this%next_close) + + if( allocated(this%fms2io_fileobj)) write( unit_num, *)'fileobj path', this%fms2io_fileobj%path + + write( unit_num, *)'type_of_domain', this%type_of_domain + if( allocated(this%file_metadata_from_model)) write( unit_num, *) 'file_metadata_from_model', & + this%file_metadata_from_model + if( allocated(this%field_ids)) write( unit_num, *)'field_ids', this%field_ids + if( allocated(this%field_registered)) write( unit_num, *)'field_registered', this%field_registered + if( allocated(this%num_registered_fields)) write( unit_num, *)'num_registered_fields', this%num_registered_fields + if( allocated(this%axis_ids)) write( unit_num, *)'axis_ids', this%axis_ids(1:this%number_of_axis) + +end subroutine + +!> @brief Determine if a file is regional +!! @return Flag indicating if the file is regional or not +logical pure function is_regional(this) + class(fmsDiagFileContainer_type), intent(in) :: this !< The file object + + select type (wut=>this%FMS_diag_file) + type is (subRegionalFile_type) + is_regional = .true. + type is (fmsDiagFile_type) + is_regional = .false. + end select + +end function is_regional + +!> @brief Determine if a file is static +!! @return Flag indicating if the file is static or not +logical pure function is_file_static(this) +class(fmsDiagFileContainer_type), intent(in) :: this !< The file object + +is_file_static = .false. + +select type (fileptr=>this%FMS_diag_file) +type is (fmsDiagFile_type) + is_file_static = fileptr%is_static +end select + +end function is_file_static + +!< @brief Opens the diag_file if it is time to do so +subroutine open_diag_file(this, time_step, file_is_opened) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + TYPE(time_type), intent(in) :: time_step !< Current model step time + logical, intent(out) :: file_is_opened !< .true. if the file was opened in this + !! time + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(diagDomain_t), pointer :: domain !< The domain used in the file + character(len=:), allocatable :: diag_file_name !< The file name as defined in the yaml + character(len=128) :: base_name !< The file name as defined in the yaml + !! without the wildcard definition + character(len=128) :: file_name !< The file name as it will be written to disk + character(len=128) :: temp_name !< Temp variable to store the file_name + character(len=128) :: start_date !< The start_time as a string that will be added to + !! the begining of the filename (start_date.filename) + character(len=128) :: suffix !< The current time as a string that will be added to + !! the end of filename + integer :: pos !< Index of the filename with the first "%" in the file name + INTEGER :: year !< The year of the start_date + INTEGER :: month !< The month of the start_date + INTEGER :: day !< The day of the start_date + INTEGER :: hour !< The hour of the start_date + INTEGER :: minute !< The minute of the start_date + INTEGER :: second !< The second of the start_date + character(len=4) :: mype_string !< The pe as a string + logical :: is_regional !< Flag indicating if the file is regional + integer, allocatable :: pes(:) !< Array of the pes in the current pelist + + diag_file => this%FMS_diag_file + domain => diag_file%domain + + file_is_opened = .false. + !< Go away if it the file is already open + if (diag_file%is_file_open) return + + is_regional = .false. + !< Figure out what fms2io_fileobj to use! + if (.not. allocated(diag_file%fms2io_fileobj)) then + select type (diag_file) + type is (subRegionalFile_type) + !< In this case each PE is going to write its own file + allocate(FmsNetcdfFile_t :: diag_file%fms2io_fileobj) + is_regional = .true. + type is (fmsDiagFile_type) + !< Use the type_of_domain to get the correct fms2io_fileobj + select case (diag_file%type_of_domain) + case (NO_DOMAIN) + allocate(FmsNetcdfFile_t :: diag_file%fms2io_fileobj) + case (TWO_D_DOMAIN) + allocate(FmsNetcdfDomainFile_t :: diag_file%fms2io_fileobj) + case (UG_DOMAIN) + allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fms2io_fileobj) + end select + end select + endif + + !< Figure out what to name of the file + diag_file_name = diag_file%get_file_fname() + + !< If using the new_file_freq figure out what the name is based on the current time + if (diag_file%has_file_new_file_freq()) then + !< If using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr), get the basename (i.e ocn) + pos = INDEX(diag_file_name, '%') + if (pos > 0) base_name = diag_file_name(1:pos-1) + suffix = get_time_string(diag_file_name, diag_file%get_filename_time()) + base_name = trim(base_name)//trim(suffix) + else + base_name = trim(diag_file_name) + endif + + !< Add the ens number to the file name (if it exists) + file_name = trim(base_name) + call get_instance_filename(base_name, file_name) + + !< Prepend the file start_time to the file name if prepend_date == .TRUE. in + !! the namelist + IF ( prepend_date ) THEN + call get_date(diag_file%start_time, year, month, day, hour, minute, second) + write (start_date, '(1I20.4, 2I2.2)') year, month, day + + file_name = TRIM(adjustl(start_date))//'.'//TRIM(file_name) + END IF + + file_name = trim(file_name)//".nc" + + !< If this is a regional file add the PE and the tile_number to the filename + if (is_regional) then + !< Get the pe number that will be appended to the end of the file + write(mype_string,'(I0.4)') mpp_pe() + + !< Add the tile number if appropriate + select type (domain) + type is (DIAGDOMAIN2D_T) + temp_name = file_name + call get_mosaic_tile_file(temp_name, file_name, .true., domain%domain2) + end select + + file_name = trim(file_name)//"."//trim(mype_string) + endif + + !< Open the file! + select type (fms2io_fileobj => diag_file%fms2io_fileobj) + type is (FmsNetcdfFile_t) + if (is_regional) then + if (.not. open_file(fms2io_fileobj, file_name, "overwrite", pelist=(/mpp_pe()/))) & + &call mpp_error(FATAL, "Error opening the file:"//file_name) + call register_global_attribute(fms2io_fileobj, "is_subregional", "True", str_len=4) + else + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if (.not. open_file(fms2io_fileobj, file_name, "overwrite", pelist=pes)) & + &call mpp_error(FATAL, "Error opening the file:"//file_name) + endif + type is (FmsNetcdfDomainFile_t) + select type (domain) + type is (diagDomain2d_t) + if (.not. open_file(fms2io_fileobj, file_name, "overwrite", domain%Domain2)) & + &call mpp_error(FATAL, "Error opening the file:"//file_name) + end select + type is (FmsNetcdfUnstructuredDomainFile_t) + select type (domain) + type is (diagDomainUg_t) + if (.not. open_file(fms2io_fileobj, file_name, "overwrite", domain%DomainUG)) & + &call mpp_error(FATAL, "Error opening the file:"//file_name) + end select + end select + + file_is_opened = .true. + diag_file%is_file_open = file_is_opened + domain => null() + diag_file => null() +end subroutine open_diag_file + +!< @brief Write global attributes in the diag_file +subroutine write_global_metadata(this) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + integer :: i !< For do loops + character (len=MAX_STR_LEN), allocatable :: yaml_file_attributes(:,:) !< Global attributes defined in the yaml + + type(diagYamlFiles_type), pointer :: diag_file_yaml !< The diag_file yaml + + diag_file_yaml => this%FMS_diag_file%diag_yaml_file + fms2io_fileobj => this%FMS_diag_file%fms2io_fileobj + + if (diag_file_yaml%has_file_global_meta()) then + yaml_file_attributes = diag_file_yaml%get_file_global_meta() + do i = 1, size(yaml_file_attributes,1) + call register_global_attribute(fms2io_fileobj, trim(yaml_file_attributes(i,1)), & + trim(yaml_file_attributes(i,2)), str_len=len_trim(yaml_file_attributes(i,2))) + enddo + deallocate(yaml_file_attributes) + endif +end subroutine write_global_metadata + +!< @brief Writes a variable's metadata in the netcdf file +subroutine write_var_metadata(fms2io_fileobj, variable_name, dimensions, long_name, units) + class(FmsNetcdfFile_t), intent(inout) :: fms2io_fileobj !< The file object to write into + character(len=*) , intent(in) :: variable_name !< The name of the time variables + character(len=*) , intent(in) :: dimensions(:) !< The dimensions of the variable + character(len=*) , intent(in) :: long_name !< The long_name of the variable + character(len=*) , intent(in) :: units !< The units of the variable + + call register_field(fms2io_fileobj, variable_name, pack_size_str, dimensions) + call register_variable_attribute(fms2io_fileobj, variable_name, "long_name", & + trim(long_name), str_len=len_trim(long_name)) + if (trim(units) .ne. no_units) & + call register_variable_attribute(fms2io_fileobj, variable_name, "units", & + trim(units), str_len=len_trim(units)) +end subroutine write_var_metadata + +!> \brief Write the time metadata to the diag file +subroutine write_time_metadata(this) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + character(len=50) :: time_units_str !< Time units written as a string + character(len=50) :: calendar !< The calendar name + + character(len=:), allocatable :: time_var_name !< The name of the time variable as it is defined in the yaml + character(len=50) :: dimensions(2) !< Array of dimensions names for the variable + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + time_var_name = diag_file%get_file_unlimdim() + call register_axis(fms2io_fileobj, time_var_name, unlimited) + + WRITE(time_units_str, 11) & + TRIM(time_unit_list(diag_file%get_file_timeunit())), get_base_year(),& + & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second() +11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2) + + dimensions(1) = "nv" + dimensions(2) = trim(time_var_name) + + call write_var_metadata(fms2io_fileobj, time_var_name, dimensions(2:2), & + time_var_name, time_units_str) + + !< Add additional variables to the time variable + call register_variable_attribute(fms2io_fileobj, time_var_name, "axis", "T", str_len=1 ) + + !TODO no need to have both attributes, probably? + calendar = valid_calendar_types(get_calendar_type()) + call register_variable_attribute(fms2io_fileobj, time_var_name, "calendar_type", & + uppercase(trim(calendar)), str_len=len_trim(calendar)) + call register_variable_attribute(fms2io_fileobj, time_var_name, "calendar", & + lowercase(trim(calendar)), str_len=len_trim(calendar)) + + if (diag_file%time_ops) then + call register_variable_attribute(fms2io_fileobj, time_var_name, "bounds", & + trim(time_var_name)//"_bnds", str_len=len_trim(time_var_name//"_bnds")) + + !< Write out the "average_*" variables metadata + call write_var_metadata(fms2io_fileobj, avg_name//"_T1", dimensions(2:2), & + "Start time for average period", time_units_str) + call write_var_metadata(fms2io_fileobj, avg_name//"_T2", dimensions(2:2), & + "End time for average period", time_units_str) + call write_var_metadata(fms2io_fileobj, avg_name//"_DT", dimensions(2:2), & + "Length of average period", time_unit_list(diag_file%get_file_timeunit())) + + !< It is possible that the "nv" "axis" was registered via "diag_axis_init" call + !! so only adding it if it doesn't exist already + if ( .not. dimension_exists(fms2io_fileobj, "nv")) then + call register_axis(fms2io_fileobj, "nv", 2) !< Time bounds need a vertex number + call write_var_metadata(fms2io_fileobj, "nv", dimensions(1:1), & + "vertex number", no_units) + endif + call write_var_metadata(fms2io_fileobj, time_var_name//"_bnds", dimensions, & + trim(time_var_name)//" axis boundaries", time_units_str) + endif + +end subroutine write_time_metadata + +!> \brief Write out the field data to the file +subroutine write_field_data(this, field_obj, buffer_obj) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to + type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from + type(fmsDiagOutputBuffer_type), intent(inout), target :: buffer_obj(:) !< The buffer object with the data + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to + integer :: i !< For do loops + integer :: field_id !< The id of the field writing the data from + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + !TODO This may be offloaded in the future + if (diag_file%is_static) then + !< Here the file is static so there is no need for the unlimited dimension + !! as a variables are static + do i = 1, diag_file%number_of_buffers + call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj) + enddo + else + do i = 1, diag_file%number_of_buffers + field_id = buffer_obj(diag_file%buffer_ids(i))%get_field_id() + if (field_obj(field_id)%is_static()) then + !< If the variable is static, only write it the first time + if (diag_file%unlim_dimension_level .eq. 1) & + call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj) + else + call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj, & + unlim_dim_level=diag_file%unlim_dimension_level) + endif + enddo + endif + +end subroutine write_field_data + +!> \brief Determine if it is time to close the file +!! \return .True. if it is time to close the file +logical function is_time_to_close_file (this, time_step) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + TYPE(time_type), intent(in) :: time_step !< Current model step time + + if (time_step >= this%FMS_diag_file%next_close) then + is_time_to_close_file = .true. + else + is_time_to_close_file = .false. + endif +end function + +!> \brief Determine if it is time to "write" to the file +logical function is_time_to_write(this, time_step) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + TYPE(time_type), intent(in) :: time_step !< Current model step time + + if (time_step >= this%FMS_diag_file%next_output) then + is_time_to_write = .true. + if (this%FMS_diag_file%is_static) return + if (time_step > this%FMS_diag_file%next_next_output) & + call mpp_error(FATAL, this%FMS_diag_file%get_file_fname()//& + &": Diag_manager_mod:: You skipped a time_step. Be sure that diag_send_complete is called at every time step "& + &" needed by the file.") + else + is_time_to_write = .false. + endif +end function is_time_to_write + +!> \brief Determine if the current PE has data to write +logical function writing_on_this_pe(this) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + + select type(diag_file => this%FMS_diag_file) + type is (subRegionalFile_type) + writing_on_this_pe = diag_file%write_on_this_pe + class default + writing_on_this_pe = .true. + end select + +end function + +!> \brief Write out the time data to the file +subroutine write_time_data(this) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + + real :: dif !< The time as a real number + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + TYPE(time_type) :: middle_time !< The middle time of the averaging period + + real :: T1 !< The beginning time of the averaging period + real :: T2 !< The ending time of the averaging period + real :: DT !< The difference between the ending and beginning time of the averaging period + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + if (diag_file%time_ops) then + middle_time = (diag_file%last_output+diag_file%next_output)/2 + dif = get_date_dif(middle_time, get_base_time(), diag_file%get_file_timeunit()) + else + dif = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit()) + endif + + call write_data(fms2io_fileobj, diag_file%get_file_unlimdim(), dif, & + unlim_dim_level=diag_file%unlim_dimension_level) + + if (diag_file%time_ops) then + T1 = get_date_dif(diag_file%last_output, get_base_time(), diag_file%get_file_timeunit()) + T2 = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit()) + DT = T2 - T1 + + call write_data(fms2io_fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlim_dimension_level) + call write_data(fms2io_fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlim_dimension_level) + call write_data(fms2io_fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlim_dimension_level) + call write_data(fms2io_fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", & + (/T1, T2/), unlim_dim_level=diag_file%unlim_dimension_level) + + if (diag_file%unlim_dimension_level .eq. 1) then + call write_data(fms2io_fileobj, "nv", (/1, 2/)) + endif + endif + +end subroutine write_time_data + +!> \brief Updates the current_new_file_freq_index if using a new_file_freq +subroutine update_current_new_file_freq_index(this, time_step) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + TYPE(time_type), intent(in) :: time_step !< Current model step time + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + + diag_file => this%FMS_diag_file + + if (time_step >= diag_file%no_more_data) then + call diag_file%diag_yaml_file%increase_new_file_freq_index() + + if (diag_file%has_file_duration()) then + diag_file%no_more_data = diag_time_inc(diag_file%no_more_data, diag_file%get_file_duration(), & + diag_file%get_file_duration_units()) + else + !< At this point you are done writing data + diag_file%done_writing_data = .true. + diag_file%no_more_data = diag_time_inc(diag_file%no_more_data, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + diag_file%next_output = diag_file%no_more_data + diag_file%next_next_output = diag_file%no_more_data + diag_file%last_output = diag_file%no_more_data + diag_file%next_close = diag_file%no_more_data + endif + endif +end subroutine update_current_new_file_freq_index + +!> \brief Set up the next_output and next_next_output variable in a file obj +subroutine update_next_write(this, time_step) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + TYPE(time_type), intent(in) :: time_step !< Current model step time + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + + diag_file => this%FMS_diag_file + if (diag_file%is_static) then + diag_file%last_output = diag_file%next_output + diag_file%next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + diag_file%next_next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + else + diag_file%last_output = diag_file%next_output + diag_file%next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), & + diag_file%get_file_frequnit()) + diag_file%next_next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), & + diag_file%get_file_frequnit()) + endif + +end subroutine update_next_write + +!> \brief Increase the unlimited dimension level that the file is currently being written to +subroutine increase_unlim_dimension_level(this) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + + this%FMS_diag_file%unlim_dimension_level = this%FMS_diag_file%unlim_dimension_level + 1 +end subroutine increase_unlim_dimension_level + +!> \brief Get the unlimited dimension level that is in the file +!! \return The unlimited dimension +pure function get_unlim_dimension_level(this) & +result(res) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object + integer :: res + + res = this%FMS_diag_file%unlim_dimension_level +end function + +!< @brief Writes the axis metadata for the file +subroutine write_axis_metadata(this, diag_axis) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + class(fmsDiagAxisContainer_type), intent(in), target :: diag_axis(:) !< Diag_axis object + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + integer :: i,k !< For do loops + integer :: parent_axis_id !< Id of the parent_axis + integer :: structured_ids(2) !< Ids of the uncompress axis + integer :: edges_id !< Id of the axis edge + + class(fmsDiagAxisContainer_type), pointer :: axis_ptr !< pointer to the axis object currently writing + logical :: edges_in_file !< .true. if the edges are already in the file + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + do i = 1, diag_file%number_of_axis + edges_in_file = .false. + axis_ptr => diag_axis(diag_file%axis_ids(i)) + parent_axis_id = axis_ptr%axis%get_parent_axis_id() + + edges_id = axis_ptr%axis%get_edges_id() + if (edges_id .ne. diag_null) then + !< write the edges if is not in the list of axis in the file, otherwrise ignore + if (any(diag_file%axis_ids(1:diag_file%number_of_axis) .eq. edges_id)) then + edges_in_file = .true. + else + call diag_axis(edges_id)%axis%write_axis_metadata(fms2io_fileobj, .true.) + endif + endif + + if (parent_axis_id .eq. DIAG_NULL) then + call axis_ptr%axis%write_axis_metadata(fms2io_fileobj, edges_in_file) + else + call axis_ptr%axis%write_axis_metadata(fms2io_fileobj, edges_in_file, diag_axis(parent_axis_id)%axis) + endif + + if (axis_ptr%axis%is_unstructured_grid()) then + structured_ids = axis_ptr%axis%get_structured_axis() + do k = 1, size(structured_ids) + call diag_axis(structured_ids(k))%axis%write_axis_metadata(fms2io_fileobj, .false.) + enddo + endif + + enddo + +end subroutine write_axis_metadata + +!< @brief Writes the field metadata for the file +subroutine write_field_metadata(this, diag_field, diag_axis) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + class(fmsDiagField_type) , intent(inout), target :: diag_field(:) !< + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object + + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(fmsDiagField_type), pointer :: field_ptr !< diag_field(diag_file%field_ids(i)), for convenience + + integer :: i !< For do loops + logical :: is_regional !< Flag indicating if the field is in a regional file + character(len=255) :: cell_measures !< cell_measures attributes for the field + + is_regional = this%is_regional() + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + do i = 1, size(diag_file%field_ids) + if (.not. diag_file%field_registered(i)) cycle !TODO do something else here + field_ptr => diag_field(diag_file%field_ids(i)) + + !TODO I think if the area and the volume field are no in the same file, a global attribute containing the + !the file that the fields are in needs to be added + cell_measures = "" + if (field_ptr%has_area()) then + cell_measures = "area: "//diag_field(field_ptr%get_area())%get_varname(to_write=.true.) + endif + + if (field_ptr%has_volume()) then + cell_measures = trim(cell_measures)//" volume: "//diag_field(field_ptr%get_volume())%get_varname(to_write=.true.) + endif + + call field_ptr%write_field_metadata(fms2io_fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, & + this%FMS_diag_file%get_file_unlimdim(), is_regional, cell_measures) + enddo + +end subroutine write_field_metadata + +!< @brief Writes the axis data for the file +subroutine write_axis_data(this, diag_axis) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to + integer :: i, k !< For do loops + integer :: j !< diag_file%axis_ids(i) (for less typing) + integer :: parent_axis_id !< Id of the parent_axis + integer :: structured_ids(2) !< Ids of the uncompress axis + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + do i = 1, diag_file%number_of_axis + j = diag_file%axis_ids(i) + parent_axis_id = diag_axis(j)%axis%get_parent_axis_id() + if (parent_axis_id .eq. DIAG_NULL) then + call diag_axis(j)%axis%write_axis_data(fms2io_fileobj) + else + call diag_axis(j)%axis%write_axis_data(fms2io_fileobj, diag_axis(parent_axis_id)%axis) + endif + + if (diag_axis(j)%axis%is_unstructured_grid()) then + structured_ids = diag_axis(j)%axis%get_structured_axis() + do k = 1, size(structured_ids) + call diag_axis(structured_ids(k))%axis%write_axis_data(fms2io_fileobj) + enddo + endif + enddo + +end subroutine write_axis_data + +!< @brief Closes the diag_file +subroutine close_diag_file(this) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object + + if (.not. this%FMS_diag_file%is_file_open) return + + !< The select types are needed here because otherwise the code will go to the + !! wrong close_file routine and things will not close propertly + select type( fms2io_fileobj => this%FMS_diag_file%fms2io_fileobj) + type is (FmsNetcdfDomainFile_t) + call close_file(fms2io_fileobj) + type is (FmsNetcdfFile_t) + call close_file(fms2io_fileobj) + type is (FmsNetcdfUnstructuredDomainFile_t) + call close_file(fms2io_fileobj) + end select + + !< Reset the unlimited dimension level back to 0, in case the fms2io_fileobj is re-used + this%FMS_diag_file%unlim_dimension_level = 0 + this%FMS_diag_file%is_file_open = .false. + + if (this%FMS_diag_file%has_file_new_file_freq()) then + this%FMS_diag_file%next_close = diag_time_inc(this%FMS_diag_file%next_close, & + this%FMS_diag_file%get_file_new_file_freq(), & + this%FMS_diag_file%get_file_new_file_freq_units()) + else + this%FMS_diag_file%next_close = diag_time_inc(this%FMS_diag_file%next_close, VERY_LARGE_FILE_FREQ, DIAG_DAYS) + endif +end subroutine close_diag_file + +#endif +end module fms_diag_file_object_mod diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90 new file mode 100644 index 0000000000..12257734ce --- /dev/null +++ b/diag_manager/fms_diag_input_buffer.F90 @@ -0,0 +1,192 @@ +!*********************************************************************** +!* 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_input_buffer_mod fms_diag_input_buffer_mod +!> @ingroup diag_manager +!! @brief +!> @addtogroup fms_diag_input_buffer_mod +!> @{ +module fms_diag_input_buffer_mod +#ifdef use_yaml + use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind + use fms_diag_axis_object_mod, only: fmsDiagAxisContainer_type, fmsDiagFullAxis_type + implicit NONE + private + + !> @brief Type to hold the information needed for the input buffer + !! This is used when set_math_needs_to_be_done = .true. (i.e calling send_data + !! from an openmp region with multiple threads) + type fmsDiagInputBuffer_t + logical :: initialized !< .True. if the input buffer has been initialized + class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data + real(kind=r8_kind) :: weight !< Weight passed in send_data + + contains + procedure :: get_buffer + procedure :: get_weight + procedure :: init => init_input_buffer_object + procedure :: set_input_buffer_object + procedure :: is_initialized + end type fmsDiagInputBuffer_t + + public :: fmsDiagInputBuffer_t + + contains + + !> @brief Get the buffer from the input buffer object + !! @return a pointer to the buffer + function get_buffer(this) & + result(buffer) + class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object + class(*), pointer :: buffer(:,:,:,:) + + buffer => this%buffer + end function get_buffer + + + !> @brief Get the weight from the input buffer object + !! @return a pointer to the weight + function get_weight(this) & + result(weight) + class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object + real(kind=r8_kind), pointer :: weight + + weight => this%weight + end function get_weight + + !> @brief Initiliazes an input data buffer + !! @return Error message if something went wrong + function init_input_buffer_object(this, input_data, axis_ids, diag_axis) & + result(err_msg) + class(fmsDiagInputBuffer_t), intent(out) :: this !< input buffer object + class(*), intent(in) :: input_data(:,:,:,:) !< input data + integer, target, intent(in) :: axis_ids(:) !< axis ids for the field + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of diag_axis + character(len=128) :: err_msg + + integer :: naxes !< The number of axes in the field + integer, parameter :: ndims = 4 !< Number of dimensions + integer :: length(ndims) !< The length of an axis + integer :: a !< For looping through axes + integer, pointer :: axis_id !< The axis ID + + err_msg = "" + + !! Use the axis to get the size + !> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length + !! of 1. + length = 1 + naxes = size(axis_ids) + axis_loop: do a = 1,naxes + axis_id => axis_ids(a) + select type (axis => diag_axis(axis_id)%axis) + type is (fmsDiagFullAxis_type) + length(a) = axis%axis_length() + end select + enddo axis_loop + + select type (input_data) + type is (real(r4_kind)) + allocate(real(kind=r4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (real(r8_kind)) + allocate(real(kind=r8_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (integer(i4_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (integer(i8_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + class default + err_msg = "The data input is not one of the supported types."& + "Only r4, r8, i4, and i8 types are supported." + end select + + this%weight = 1.0_r8_kind + this%initialized = .true. + end function init_input_buffer_object + + !> @brief Sets the members of the input buffer object + !! @return Error message if something went wrong + function set_input_buffer_object(this, input_data, weight, is, js, ks, ie, je, ke) & + result(err_msg) + + class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object + class(*), intent(in) :: input_data(:,:,:,:) !< Field data + real(kind=r8_kind), intent(in) :: weight !< Weight for the field + integer, intent(in) :: is, js, ks !< Starting index for each of the dimension + integer, intent(in) :: ie, je, ke !< Ending index for each of the dimensions + + character(len=128) :: err_msg + err_msg = "" + + if (.not. this%initialized) then + err_msg = "The data buffer was never initiliazed. This shouldn't happen." + return + endif + + this%weight = weight + + select type (input_data) + type is (real(kind=r4_kind)) + select type (db => this%buffer) + type is (real(kind=r4_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (r4_kind). This shouldn't happen" + return + end select + type is (real(kind=r8_kind)) + select type (db => this%buffer) + type is (real(kind=r8_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (r8_kind). This shouldn't happen" + return + end select + type is (integer(kind=i4_kind)) + select type (db => this%buffer) + type is (integer(kind=i4_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (i4_kind). This shouldn't happen" + return + end select + type is (integer(kind=i8_kind)) + select type (db => this%buffer) + type is (integer(kind=i8_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (i8_kind). This shouldn't happen" + return + end select + end select + end function set_input_buffer_object + + !> @brief Determine if an input buffer is initialized + !! @return .true. if the input buffer is initialized + pure logical function is_initialized(this) + class(fmsDiagInputBuffer_t), intent(in) :: this !< input buffer object + + is_initialized = .false. + if (this%initialized) then + is_initialized = .true. + else + if (allocated(this%buffer)) is_initialized = .true. + endif + end function is_initialized +#endif +end module fms_diag_input_buffer_mod +!> @} diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 new file mode 100644 index 0000000000..d92d6a9cf2 --- /dev/null +++ b/diag_manager/fms_diag_object.F90 @@ -0,0 +1,1325 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +module fms_diag_object_mod +use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout +use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & + &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & + &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, & + &time_none, time_max, time_min, time_sum, time_average, time_diurnal, & + &time_power, time_rms, r8 + + USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& + & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & + & get_ticks_per_second +#ifdef use_yaml +use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init +use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value +use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, & + & get_diag_files_id, diag_yaml, get_diag_field_ids, DiagYamlFilesVar_type +use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, & + &diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, & + &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, & + &parse_compress_att, get_axis_id_from_name +use fms_diag_output_buffer_mod +use fms_mod, only: fms_error_handler +use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight +use constants_mod, only: SECONDS_PER_DAY +#endif +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region +#if defined(_OPENMP) +use omp_lib +#endif +use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d +use fms_string_utils_mod, only: string +use platform_mod +implicit none +private + +type fmsDiagObject_type +!TODO add container arrays +#ifdef use_yaml +private +!TODO: Remove FMS prefix from variables in this type + class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files + class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields + type(fmsDiagOutputBuffer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects + !! one for each variable in the diag_table.yaml + integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension + class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis + type(time_type) :: current_model_time !< The current model time + integer, private :: registered_variables !< Number of registered variables + integer, private :: registered_axis !< Number of registered axis + logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: files_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: fields_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: buffers_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: axes_initialized=.false. !< True if the fmsDiagObject is initialized +#endif + contains + procedure :: init => fms_diag_object_init + procedure :: diag_end => fms_diag_object_end + procedure :: fms_register_diag_field_scalar + procedure :: fms_register_diag_field_array + procedure :: fms_register_static_field + procedure :: fms_diag_axis_init + procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. + procedure :: fms_diag_field_add_attribute + procedure :: fms_diag_axis_add_attribute + procedure :: fms_get_domain2d + procedure :: fms_get_axis_length + procedure :: fms_get_diag_field_id_from_name + procedure :: fms_get_field_name_from_id + procedure :: fms_get_axis_name_from_id + procedure :: fms_diag_accept_data + procedure :: fms_diag_send_complete + procedure :: fms_diag_do_io + procedure :: fms_diag_do_reduction + procedure :: fms_diag_field_add_cell_measures + procedure :: allocate_diag_field_output_buffers + procedure :: fms_diag_compare_window +#ifdef use_yaml + procedure :: get_diag_buffer +#endif +end type fmsDiagObject_type + +type (fmsDiagObject_type), target :: fms_diag_object + +public :: fms_register_diag_field_obj +public :: fms_register_diag_field_scalar +public :: fms_register_diag_field_array +public :: fms_register_static_field +public :: fms_diag_field_add_attribute +public :: fms_get_diag_field_id_from_name +public :: fms_diag_object +public :: fmsDiagObject_type +integer, private :: registered_variables !< Number of registered variables +public :: dump_diag_obj + +contains + +!> @brief Initiliazes the fms_diag_object. +!! Reads the diag_table.yaml and fills in the yaml object +!! Allocates the diag manager object arrays for files, fields, and buffers +!! Initializes variables +subroutine fms_diag_object_init (this,diag_subset_output) + class(fmsDiagObject_type) :: this !< Diag mediator/controller object + integer :: diag_subset_output !< Subset of the diag output? +#ifdef use_yaml + if (this%initialized) return + +! allocate(diag_objs(get_num_unique_fields())) + CALL diag_yaml_object_init(diag_subset_output) + this%axes_initialized = fms_diag_axis_object_init(this%diag_axis) + this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files) + this%fields_initialized = fms_diag_fields_object_init(this%FMS_diag_fields) + this%buffers_initialized =fms_diag_output_buffer_init(this%FMS_diag_output_buffers,SIZE(diag_yaml%get_diag_fields())) + this%registered_variables = 0 + this%registered_axis = 0 + this%current_model_time = get_base_time() + this%initialized = .true. +#else + call mpp_error("fms_diag_object_init",& + "You must compile with -Duse_yaml to use the option use_modern_diag", FATAL) +#endif +end subroutine fms_diag_object_init + +!> \description Loops through all files and does one final write. +!! Closes all files +!! Deallocates all buffers, fields, and files +!! Uninitializes the fms_diag_object +subroutine fms_diag_object_end (this, time) + class(fmsDiagObject_type) :: this + TYPE(time_type), INTENT(in) :: time + + integer :: i +#ifdef use_yaml + !TODO: loop through files and force write + if (.not. this%initialized) return + + call this%fms_diag_do_io(is_end_of_run=.true.) + !TODO: Deallocate diag object arrays and clean up all memory + do i=1, size(this%FMS_diag_output_buffers) + call this%FMS_diag_output_buffers(i)%flush_buffer() + enddo + deallocate(this%FMS_diag_output_buffers) + this%axes_initialized = fms_diag_axis_object_end(this%diag_axis) + this%initialized = .false. + call diag_yaml_object_end +#else + call mpp_error(FATAL, "You can not call fms_diag_object%end without yaml") +#endif +end subroutine fms_diag_object_end + +!> @brief Registers a field. +!! @description This to avoid having duplicate code in each of the _scalar, _array and _static register calls +!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not +!! in the diag_table.yaml +integer function fms_register_diag_field_obj & + (this, 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, static) + + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: modname !< The module name + CHARACTER(len=*), INTENT(in) :: varname !< The variable name + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time + INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies + CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name + class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute + class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + LOGICAL, OPTIONAL, INTENT(in) :: static !< True if the variable is static +#ifdef use_yaml + + class (fmsDiagFile_type), pointer :: fileptr !< Pointer to the diag_file + class (fmsDiagField_type), pointer :: fieldptr !< Pointer to the diag_field + class (fmsDiagOutputBuffer_type), pointer :: bufferptr !< Pointer to the output buffer + integer, allocatable :: file_ids(:) !< The file IDs for this variable + integer :: i !< For do loops + integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml +#endif +#ifndef use_yaml +fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + diag_field_indices = find_diag_field(varname, modname) + if (diag_field_indices(1) .eq. diag_null) then + !< The field was not found in the table, so return DIAG_FIELD_NOT_FOUND + fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND + deallocate(diag_field_indices) + return + endif + + this%registered_variables = this%registered_variables + 1 + fms_register_diag_field_obj = this%registered_variables + + call this%FMS_diag_fields(this%registered_variables)%& + &setID(this%registered_variables) + +!> Use pointers for convenience + fieldptr => this%FMS_diag_fields(this%registered_variables) +!> Get the file IDs from the field indicies from the yaml + file_ids = get_diag_files_id(diag_field_indices) + call fieldptr%set_file_ids(file_ids) + +!> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices) +!! of the sorted variable list + fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices) + do i = 1, size(fieldptr%buffer_ids) + bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i)) + call bufferptr%set_field_id(this%registered_variables) + call bufferptr%set_yaml_id(fieldptr%buffer_ids(i)) + enddo + +!> Allocate and initialize member buffer_allocated of this field + fieldptr%buffer_allocated = .false. + +!> Register the data for the field + call fieldptr%register(modname, varname, diag_field_indices, this%diag_axis, & + axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, & + mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, & + static=static) + +!> Add the axis information, initial time, and field IDs to the files + if (present(axes) .and. present(init_time)) then + do i = 1, size(file_ids) + fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) + call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) + call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i)) + call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), & + fieldptr%buffer_ids(i), this%FMS_diag_output_buffers) + call fileptr%add_start_time(init_time, this%current_model_time) + call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) + enddo + elseif (present(axes)) then !only axes present + do i = 1, size(file_ids) + fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) + call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i)) + call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) + call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), & + fieldptr%buffer_ids(i), this%FMS_diag_output_buffers) + call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) + enddo + elseif (present(init_time)) then !only inti time present + do i = 1, size(file_ids) + fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) + call fileptr%add_start_time(init_time, this%current_model_time) + call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) + enddo + else !no axis or init time present + do i = 1, size(file_ids) + fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) + call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) + enddo + endif + nullify (fileptr) + nullify (fieldptr) + deallocate(diag_field_indices) +#endif +end function fms_register_diag_field_obj + +!> @brief Registers a scalar field +!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not +!! in the diag_table.yaml +INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, & + & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& + & area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute +#ifndef use_yaml +fms_register_diag_field_scalar=DIAG_FIELD_NOT_FOUND +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + fms_register_diag_field_scalar = this%register(& + & module_name, field_name, init_time=init_time, & + & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & + & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & area=area, volume=volume, realm=realm) +#endif +end function fms_register_diag_field_scalar + +!> @brief Registers an array field +!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not +!! in the diag_table.yaml +INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, & + & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& + & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + +#ifndef use_yaml +fms_register_diag_field_array=DIAG_FIELD_NOT_FOUND +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + fms_register_diag_field_array = this%register( & + & module_name, field_name, init_time=init_time, & + & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & + & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) +#endif +end function fms_register_diag_field_array + +!> @brief Return field index for subsequent call to send_data. +!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not +!! in the diag_table.yaml +INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& + & tile_count, area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute + CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has + !! a mask variant + LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated + !! with this field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated + !! with this field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + +#ifndef use_yaml +fms_register_static_field=DIAG_FIELD_NOT_FOUND +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + !TODO The register_static_field interface does not have the capabiliy to register a variable as a "scalar" + ! since the axes argument is required, this forced model code to pass in a null_axis_id as an argument + if (size(axes) .eq. 1 .and. axes(1) .eq. null_axis_id) then + ! If they are passing in the null_axis_ids, ignore the `axes` argument + fms_register_static_field = this%register( & + & module_name, field_name, & + & longname=long_name, units=units, missing_value=missing_value, varrange=range, & + & mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, & + & standname=standard_name, area=area, volume=volume, realm=realm, & + & static=.true.) + else + fms_register_static_field = this%register( & + & module_name, field_name, axes=axes, & + & longname=long_name, units=units, missing_value=missing_value, varrange=range, & + & mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, & + & standname=standard_name, area=area, volume=volume, realm=realm, & + & static=.true.) + endif +#endif +end function fms_register_static_field + +!> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init +!! interface the same +!> @return Axis id +FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, axis_length, long_name, direction,& + & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) & + & result(id) + + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis + CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values + CHARACTER(len=*), INTENT(in) :: units !< Units for the axis + CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N") + integer, intent(in) :: axis_length !< The length of the axis size(axis_data(:)) + CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. + CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis + INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis + INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis" + TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain + TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain + TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain + CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t + !! or geolat_t + CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names. + INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles + INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST" + integer :: id + +#ifndef use_yaml +id = diag_null +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + CHARACTER(len=:), ALLOCATABLE :: edges_name !< Name of the edges + + this%registered_axis = this%registered_axis + 1 + + if (this%registered_axis > max_axes) call mpp_error(FATAL, & + &"diag_axis_init: max_axes exceeded, increase via diag_manager_nml") + + allocate(fmsDiagFullAxis_type :: this%diag_axis(this%registered_axis)%axis) + + select type (axis => this%diag_axis(this%registered_axis)%axis ) + type is (fmsDiagFullAxis_type) + if(present(edges)) then + if (edges < 0 .or. edges > this%registered_axis) & + call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "& + "Call diag_axis_init for the edge axis first") + select type (edges_axis => this%diag_axis(edges)%axis) + type is (fmsDiagFullAxis_type) + edges_name = edges_axis%get_axis_name() + call axis%set_edges(edges_name, edges) + end select + endif + call axis%register(axis_name, axis_data, units, cart_name, long_name=long_name, & + & direction=direction, set_name=set_name, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, & + & req=req, tile_count=tile_count, domain_position=domain_position, axis_length=axis_length) + + id = this%registered_axis + call axis%set_axis_id(id) + end select +#endif +end function fms_diag_axis_init + +!> Accepts data from the send_data functions. If this is in an openmp region with more than +!! one thread, the data is buffered in the field object and processed later. If only a single thread +!! is being used, then the processing can be done and stored in the buffer object. The hope is that +!! the increase in memory footprint related to buffering can be handled by the shared memory of the +!! multithreaded case. +!! \note If some of the diag manager is offloaded in the future, then it should be treated similarly +!! to the multi-threaded option for processing later +logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rmask, & + time, is_in, js_in, ks_in, & + ie_in, je_in, ke_in, weight, err_msg) + class(fmsDiagObject_type),TARGET, INTENT(inout) :: this !< Diaj_obj to fill + INTEGER, INTENT(in) :: diag_field_id !< The ID of the diag field + CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the diag_field + LOGICAL, allocatable, INTENT(in) :: mask(:,:,:,:) !< Logical mask indicating the grid + !! points to mask (null if no mask) + CLASS(*), allocatable, INTENT(in) :: rmask(:,:,:,:)!< real mask indicating the grid + !! points to mask (null if no mask) + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging + TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in !< Starting indices + INTEGER, INTENT(in), OPTIONAL :: ie_in, je_in, ke_in !< Ending indices + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned + + integer :: is, js, ks !< Starting indicies of the field_data + integer :: ie, je, ke !< Ending indicies of the field_data + integer :: omp_num_threads !< Number of openmp threads + integer :: omp_level !< The openmp active level + logical :: buffer_the_data !< True if the user selects to buffer the data and run + !! the calculationslater. \note This is experimental + character(len=128) :: error_string !< Store error text + logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated + character(len=256) :: field_info !< String holding info about the field to append to the + !! error message + logical, allocatable, dimension(:,:,:,:) :: oor_mask !< Out of range mask + real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted + !! based on the type of field_data when doing the math) + type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field + logical :: has_halos !< .True. if field_data contains halos + logical :: using_blocking !< .True. if field_data is passed in blocks +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname()) + + !< Check if time should be present for this field + if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) & + call mpp_error(FATAL, "Time must be present if the field is not static. "//trim(field_info)) + + !< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind + field_weight = set_weight(weight) + + !< Check that the indices are present in the correct combination + error_string = check_indices_order(is_in, ie_in, js_in, je_in) + if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + + using_blocking = .false. + if ((present(is_in) .and. .not. present(ie_in)) .or. (present(js_in) .and. .not. present(je_in))) & + using_blocking = .true. + + has_halos = .false. + if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) & + has_halos = .true. + + !< If the field has `mask_variant=.true.`, check that mask OR rmask are present + if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then + if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, & + "The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//& + trim(field_info)) + else + if (allocated(mask) .or. allocated(rmask)) & + call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.) + endif + + !< Check that mask and rmask are not both present + if (allocated(mask) .and. allocated(rmask)) call mpp_error(FATAL, & + "mask and rmask are both present in the send_data call. "//& + trim(field_info)) + + !< Create the oor_mask based on the "mask" and "rmask" arguments + oor_mask = init_mask(rmask, mask, field_data) + + !> Does the user want to push off calculations until send_diag_complete? + buffer_the_data = .false. + + !> initialize the number of threads and level to be 0 + omp_num_threads = 0 + omp_level = 0 +#if defined(_OPENMP) + omp_num_threads = omp_get_num_threads() + omp_level = omp_get_level() + buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0) +#endif + + !> Calculate the i,j,k start and end + ! If is, js, or ks not present default them to 1 + is = 1 + js = 1 + ks = 1 + IF ( PRESENT(is_in) ) is = is_in + IF ( PRESENT(js_in) ) js = js_in + IF ( PRESENT(ks_in) ) ks = ks_in + ie = is+SIZE(field_data, 1)-1 + je = js+SIZE(field_data, 2)-1 + ke = ks+SIZE(field_data, 3)-1 + IF ( PRESENT(ie_in) ) ie = ie_in + IF ( PRESENT(je_in) ) je = je_in + IF ( PRESENT(ke_in) ) ke = ke_in + + !If this is true, buffer data + main_if: if (buffer_the_data) then +!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done +!$omp critical + if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then + data_buffer_is_allocated = & + this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis) + call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis) + endif + call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.) + call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.) +!$omp end critical + call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, field_weight, & + is, js, ks, ie, je, ke) + call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, is, js, ks, ie, je, ke) + fms_diag_accept_data = .TRUE. + return + else + error_string = bounds%set_bounds(field_data, is, ie, js, je, ks, ke, has_halos) + if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + + call this%allocate_diag_field_output_buffers(field_data, diag_field_id) + error_string = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & + bounds, using_blocking, Time=Time) + if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) + call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask) + call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask) + return + end if main_if + !> Return false if nothing is done + fms_diag_accept_data = .FALSE. + return +#endif +end function fms_diag_accept_data +!! TODO: This entire routine +!> @brief Loops through all the files, open the file, writes out axis and +!! variable metadata and data when necessary. +subroutine fms_diag_send_complete(this, time_step) + class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object + TYPE (time_type), INTENT(in) :: time_step !< The time_step + + integer :: i !< For do loops + + integer :: ifile !< For file loops + integer :: ifield !< For field loops +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + + class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience + class(fmsDiagField_type), pointer :: diag_field !< Pointer to this%FMS_diag_files(i)%diag_field(j) + logical :: math !< True if the math functions need to be called using the data buffer, + !! False if the math functions were done in accept_data + integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file + class(*), pointer :: input_data_buffer(:,:,:,:) + character(len=128) :: error_string + type(fmsDiagIbounds_type) :: bounds + integer, dimension(:), allocatable :: file_ids !< Array of file IDs for a field + logical, parameter :: DEBUG_SC = .true. !< turn on output for debugging + + !< Update the current model time by adding the time_step + this%current_model_time = this%current_model_time + time_step + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! In the future, this may be parallelized for offloading + ! loop through each field + field_loop: do ifield = 1, size(this%FMS_diag_fields) + diag_field => this%FMS_diag_fields(ifield) + if(.not. diag_field%is_registered()) cycle + if(DEBUG_SC) call mpp_error(NOTE, "fms_diag_send_complete:: var: "//diag_field%get_varname()) + ! get files the field is in + allocate (file_ids(size(diag_field%get_file_ids() ))) + file_ids = diag_field%get_file_ids() + math = diag_field%get_math_needs_to_be_done() + ! if doing math loop through each file for given field + doing_math: if (size(file_ids) .ge. 1 .and. math) then + ! Check if buffer alloc'd + has_input_buff: if (diag_field%has_input_data_buffer()) then + input_data_buffer => diag_field%get_data_buffer() + ! reset bounds, allocate output buffer, and update it with reduction + call bounds%reset_bounds_from_array_4D(input_data_buffer) + call this%allocate_diag_field_output_buffers(input_data_buffer, ifield) + error_string = this%fms_diag_do_reduction(input_data_buffer, ifield, & + diag_field%get_mask(), diag_field%get_weight(), & + bounds, .False., Time=this%current_model_time) + if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//& + " -"//trim(error_string))) + else + call mpp_error(FATAL, "diag_send_complete:: no input buffer allocated for field"//diag_field%get_longname()) + endif has_input_buff + endif doing_math + !> Clean up, clean up, everybody do your share + if (allocated(file_ids)) deallocate(file_ids) + if (associated(diag_field)) nullify(diag_field) + enddo field_loop + +call this%fms_diag_do_io() +#endif + +end subroutine fms_diag_send_complete + +!> @brief Loops through all the files, open the file, writes out axis and +!! variable metadata and data when necessary. +subroutine fms_diag_do_io(this, is_end_of_run) + class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object + logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run, + !! so force write +#ifdef use_yaml + integer :: i !< For do loops + class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience) + TYPE (time_type), pointer :: model_time!< The current model time + + logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step + !! If true the metadata will need to be written + logical :: force_write + + force_write = .false. + if (present (is_end_of_run)) force_write = .true. + + model_time => this%current_model_time + + do i = 1, size(this%FMS_diag_files) + diag_file => this%FMS_diag_files(i) + + !< Go away if the file is a subregional file and the current PE does not have any data for it + if (.not. diag_file%writing_on_this_pe()) cycle + + call diag_file%open_diag_file(model_time, file_is_opened_this_time_step) + if (file_is_opened_this_time_step) then + call diag_file%write_global_metadata() + call diag_file%write_axis_metadata(this%diag_axis) + call diag_file%write_time_metadata() + call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis) + call diag_file%write_axis_data(this%diag_axis) + endif + + if (diag_file%is_time_to_write(model_time)) then + call diag_file%increase_unlim_dimension_level() + call diag_file%write_time_data() + call diag_file%write_field_data(this%FMS_diag_fields, this%FMS_diag_output_buffers) + call diag_file%update_next_write(model_time) + call diag_file%update_current_new_file_freq_index(model_time) + if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file() + else if (force_write) then + if (diag_file%get_unlim_dimension_level() .eq. 0) then + call diag_file%increase_unlim_dimension_level() + call diag_file%write_time_data() + endif + call diag_file%close_diag_file() + endif + enddo +#endif +end subroutine fms_diag_do_io + +!> @brief Computes average, min, max, rms error, etc. +!! based on the specified reduction method for the field. +!> @return Empty string if successful, error message if it fails +function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & + bounds, using_blocking, time) & + result(error_msg) + class(fmsDiagObject_type), intent(inout), target:: this !< Diag Object + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + integer, intent(in) :: diag_field_id !< ID of the input field + logical, intent(in), target :: oor_mask(:,:,:,:) !< mask + real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight + type(fmsDiagIbounds_type), intent(in) :: bounds !< Bounds for the field + logical, intent(in) :: using_blocking !< .True. if field data is passed + !! in blocks + type(time_type), intent(in), optional :: time !< Current time + + character(len=50) :: error_msg !< Error message to check + !TODO Mostly everything +#ifdef use_yaml + type(fmsDiagField_type), pointer :: field_ptr !< Pointer to the field's object + type(fmsDiagOutputBuffer_type), pointer :: buffer_ptr !< Pointer to the field's buffer + class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file + type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml + + integer :: reduction_method !< Integer representing a reduction method + integer :: ids !< For looping through buffer ids + integer :: buffer_id !< Id of the buffer + integer :: file_id !< File id + integer, allocatable :: axis_ids(:) !< Axis ids for the buffer + logical :: is_subregional !< .True. if the buffer is subregional + logical :: reduced_k_range !< .True. is the field is only outputing a section + !! of the z dimension + type(fmsDiagIbounds_type) :: bounds_in !< Starting and ending indices of the input field_data + type(fmsDiagIbounds_type) :: bounds_out !< Starting and ending indices of the output buffer + integer :: i !< For looping through axid ids + integer :: sindex !< Starting index of a subregion + integer :: eindex !< Ending index of a subregion + integer :: compute_idx(2) !< Starting and Ending of the compute domain + character(len=1) :: cart_axis !< Cartesian axis of the axis + logical :: block_in_subregion !< .True. if the current block is part of the subregion + integer :: starting !< Starting index of the subregion relative to the compute domain + integer :: ending !< Ending index of the subregion relative to the compute domain + real(kind=r8_kind) :: missing_value !< Missing_value for data points that are masked + !! This will obtained as r8 and converted to the right type as + !! needed. This is to avoid yet another select type ... + + !TODO mostly everything + field_ptr => this%FMS_diag_fields(diag_field_id) + if (field_ptr%has_missing_value()) then + select type (missing_val => field_ptr%get_missing_value(r8)) + type is (real(kind=r8_kind)) + missing_value = missing_val + class default + call mpp_error(FATAl, "The missing value for the field:"//trim(field_ptr%get_varname())//& + &" was not allocated to the correct type. This shouldn't have happened") + end select + else + select type (missing_val => get_default_missing_value(r8)) + type is (real(kind=r8_kind)) + missing_value = missing_val + class default + call mpp_error(FATAl, "The missing value for the field:"//trim(field_ptr%get_varname())//& + &" was not allocated to the correct type. This shouldn't have happened") + end select + endif + + buffer_loop: do ids = 1, size(field_ptr%buffer_ids) + error_msg = "" + buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids) + file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids) + + !< Gather all the objects needed for the buffer + field_yaml_ptr => field_ptr%diag_field(ids) + buffer_ptr => this%FMS_diag_output_buffers(buffer_id) + file_ptr => this%FMS_diag_files(file_id) + + !< Go away if the file is a subregional file and the current PE does not have any data for it + if (.not. file_ptr%writing_on_this_pe()) cycle + + !< Go away if finished doing math for this buffer + if (buffer_ptr%is_done_with_math()) cycle + + bounds_out = bounds + if (.not. using_blocking) then + !< Set output bounds to start at 1:size(buffer_ptr%buffer) + call bounds_out%reset_bounds_from_array_4D(buffer_ptr%buffer(:,:,:,:,1)) + endif + + bounds_in = bounds + if (.not. bounds%has_halos) then + !< If field_data does not contain halos, set bounds_in to start at 1:size(field_data) + call bounds_in%reset_bounds_from_array_4D(field_data) + endif + + is_subregional = file_ptr%is_regional() + reduced_k_range = field_yaml_ptr%has_var_zbounds() + + !< Reset the bounds based on the reduced k range and subregional + is_subregional_reduced_k_range: if (is_subregional .or. reduced_k_range) then + axis_ids = buffer_ptr%get_axis_ids() + block_in_subregion = .true. + axis_loops: do i = 1, size(axis_ids) + !< Move on if the block does not have any data for the subregion + if (.not. block_in_subregion) cycle + + select type (diag_axis => this%diag_axis(axis_ids(i))%axis) + type is (fmsDiagSubAxis_type) + sindex = diag_axis%get_starting_index() + eindex = diag_axis%get_ending_index() + compute_idx = diag_axis%get_compute_indices() + starting=sindex-compute_idx(1)+1 + ending=eindex-compute_idx(1)+1 + if (using_blocking) then + block_in_subregion = determine_if_block_is_in_region(starting, ending, bounds, i) + if (.not. block_in_subregion) cycle + + !< Set bounds_in so that you can the correct section of the data for the block (starting at 1) + call bounds_in%rebase_input(bounds, starting, ending, i) + + !< Set bounds_out to be the correct section relative to the block starting and ending indices + call bounds_out%rebase_output(starting, ending, i) + else + !< Set bounds_in so that only the subregion section of the data will be used (starting at 1) + call bounds_in%update_index(starting, ending, i, .false.) + + !< Set bounds_out to 1:size(subregion) for the PE + call bounds_out%update_index(1, ending-starting+1, i, .true.) + endif + end select + enddo axis_loops + deallocate(axis_ids) + !< Move on to the next buffer if the block does not have any data for the subregion + if (.not. block_in_subregion) cycle + endif is_subregional_reduced_k_range + + !< Determine the reduction method for the buffer + reduction_method = field_yaml_ptr%get_var_reduction() + select case(reduction_method) + case (time_none) + error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), & + bounds_in, bounds_out, missing_value) + if (trim(error_msg) .ne. "") then + return + endif + case (time_min) + error_msg = buffer_ptr%do_time_min_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), & + bounds_in, bounds_out, missing_value) + if (trim(error_msg) .ne. "") then + return + endif + case (time_max) + error_msg = buffer_ptr%do_time_max_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), & + bounds_in, bounds_out, missing_value) + if (trim(error_msg) .ne. "") then + return + endif + case (time_sum) + error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), & + bounds_in, bounds_out, missing_value) + if (trim(error_msg) .ne. "") then + return + endif + case (time_average) + case (time_power) + case (time_rms) + case (time_diurnal) + case default + error_msg = "The reduction method is not supported. "//& + "Only none, min, max, sum, average, power, rms, and diurnal are supported." + end select + + if (field_ptr%is_static() .or. file_ptr%FMS_diag_file%is_done_writing_data()) then + call buffer_ptr%set_done_with_math() + endif + enddo buffer_loop +#else + error_msg = "" + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#endif +end function fms_diag_do_reduction + +!> @brief Adds the diag ids of the Area and or Volume of the diag_field_object +subroutine fms_diag_field_add_cell_measures(this, diag_field_id, area, volume) + class(fmsDiagObject_type), intent (inout) :: this !< The diag object + integer, intent(in) :: diag_field_id !< diag_field to add the are and volume to + INTEGER, optional, INTENT(in) :: area !< diag ids of area + INTEGER, optional, INTENT(in) :: volume !< diag ids of volume + +#ifndef use_yaml + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + call this%FMS_diag_fields(diag_field_id)%add_area_volume(area, volume) +#endif +end subroutine fms_diag_field_add_cell_measures + +!> @brief Add a attribute to the diag_obj using the diag_field_id +subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value) + class(fmsDiagObject_type), intent (inout) :: this !< The diag object + integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else +!TODO: Value for diag not found + if ( diag_field_id .LE. 0 ) THEN + RETURN + else + if (this%FMS_diag_fields(diag_field_id)%is_registered() ) & + call this%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value) + endif +#endif +end subroutine fms_diag_field_add_attribute + +!> @brief Add an attribute to an axis +subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value) + class(fmsDiagObject_type), intent (inout) :: this !< The diag object + integer, intent(in) :: axis_id !< Id of the axis to add the attribute to + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + character(len=20) :: axis_names(2) !< Names of the uncompress axis + integer :: uncmx_ids(2) !< Ids of the uncompress axis + integer :: j !< For do loops +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + if (axis_id < 0 .and. axis_id > this%registered_axis) & + call mpp_error(FATAL, "diag_axis_add_attribute: The axis_id is not valid") + + select type (axis => this%diag_axis(axis_id)%axis) + type is (fmsDiagFullAxis_type) + call axis%add_axis_attribute(att_name, att_value) + + !! Axis that are in the "unstructured" domain require a "compress" attribute for the + !! combiner and PP. This attribute is passed in via a diag_axis_add_attribute call in the model code + !! The compress attribute indicates the names of the axis that were compressed + !! For example grid_index:compress = "grid_yt grid_xt" + !! The metadata and the data for these axis also needs to be written to the file + if (trim(att_name) .eq. "compress") then + !< If the attribute is the "compress" attribute, get the axis names, + !! and the ids of the axis and add it to the axis object so it can be written to netcdf files + !! that use this axis + axis_names = parse_compress_att(att_value) + do j = 1, size(axis_names) + uncmx_ids(j) = get_axis_id_from_name(axis_names(j), this%diag_axis, this%registered_axis) + if (uncmx_ids(j) .eq. diag_null) call mpp_error(FATAL, & + &"Error parsing the compress attribute for axis: "//trim(axis%get_axis_name())//& + &". Be sure that the axes in the compress attribute are registered") + enddo + call axis%add_structured_axis_ids(uncmx_ids) + endif + end select +#endif +end subroutine fms_diag_axis_add_attribute + +!> \brief Gets the field_name from the diag_field +!> \returns a copy of the field_name +function fms_get_field_name_from_id (this, field_id) & + result(field_name) + + class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller + integer, intent (in) :: field_id !< Field id to get the name for + character(len=:), allocatable :: field_name +#ifndef use_yaml + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else + field_name = this%FMS_diag_fields(field_id)%get_varname() +#endif +end function fms_get_field_name_from_id + +!> \brief Gets the diag field ID from the module name and field name. +!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered +FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) & + result(diag_field_id) + class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller + CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable + CHARACTER(len=*), INTENT(in) :: field_name !< Variable name + integer :: diag_field_id + +#ifdef use_yaml + integer :: i !< For looping + integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml + + diag_field_id = DIAG_FIELD_NOT_FOUND + + !> Loop through fields to find it. + do i=1, this%registered_variables + !< Check if the field was registered, if it was return the diag_field_id + diag_field_id = this%FMS_diag_fields(i)%id_from_name(module_name, field_name) + if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return + enddo + + !< Check if the field is in the diag_table.yaml. If it is, return DIAG_FIELD_NOT_REGISTERED + !! Otherwsie it will return DIAG_FIELD_NOT_FOUND + diag_field_indices = find_diag_field(field_name, module_name) + if (diag_field_indices(1) .ne. diag_null) then + diag_field_id = DIAG_NOT_REGISTERED + endif + deallocate(diag_field_indices) +#else + diag_field_id = DIAG_FIELD_NOT_FOUND + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#endif +END FUNCTION fms_get_diag_field_id_from_name + +#ifdef use_yaml +!> returns the buffer object for the given id +!! actual data comes from %get_buffer_data() on the returned object +function get_diag_buffer(this, bufferid) & +result(rslt) + class(fmsDiagObject_type), intent(in) :: this + integer, intent(in) :: bufferid + class(fmsDiagOutputBuffer_type),allocatable:: rslt + if( (bufferid .gt. UBOUND(this%FMS_diag_output_buffers, 1)) .or. & + (bufferid .lt. LBOUND(this%FMS_diag_output_buffers, 1))) & + call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given') + rslt = this%FMS_diag_output_buffers(bufferid) +end function +#endif + +!> @brief Return the 2D domain for the axis IDs given. +!! @return 2D domain for the axis IDs given +type(domain2d) FUNCTION fms_get_domain2d(this, ids) + class(fmsDiagObject_type), intent (in) :: this !< The diag object + INTEGER, DIMENSION(:), INTENT(in) :: ids !< Axis IDs. + +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +fms_get_domain2d = null_domain2d +#else + INTEGER :: type_of_domain !< The type of domain + CLASS(diagDomain_t), POINTER :: domain !< Diag Domain pointer + + call get_domain_and_domain_type(fms_diag_object%diag_axis, ids, type_of_domain, domain, "get_domain2d") + if (type_of_domain .ne. TWO_D_DOMAIN) & + call mpp_error(FATAL, 'diag_axis_mod::get_domain2d- The axis do not correspond to a 2d Domain') + select type(domain) + type is (diagDomain2d_t) + fms_get_domain2d = domain%domain2 + end select +#endif +END FUNCTION fms_get_domain2d + + !> @brief Gets the length of the axis based on the axis_id + !> @return Axis_length + integer function fms_get_axis_length(this, axis_id) + class(fmsDiagObject_type), intent (in) :: this !< The diag object + INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of + +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +fms_get_axis_length = 0 +#else +fms_get_axis_length = 0 + + if (axis_id < 0 .and. axis_id > this%registered_axis) & + call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") + + select type (axis => this%diag_axis(axis_id)%axis) + type is (fmsDiagFullAxis_type) + fms_get_axis_length = axis%axis_length() + type is (fmsDiagSubAxis_type) + fms_get_axis_length = axis%axis_length() + end select +#endif +end function fms_get_axis_length + +!> @brief Gets the name of the axis based on the axis_id + !> @return The axis_name +function fms_get_axis_name_from_id (this, axis_id) & +result(axis_name) + class(fmsDiagObject_type), intent (in) :: this !< The diag object + INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of + + character (len=:), allocatable :: axis_name + +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +axis_name=" " +#else + if (axis_id < 0 .and. axis_id > this%registered_axis) & + call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") + + !! if its a scalar (null axis id) just returns n/a since no axis is defined + if (axis_id .eq. NULL_AXIS_ID) then + allocate(character(len=3) :: axis_name) + axis_name = "n/a" + return + endif + + + select type (axis => this%diag_axis(axis_id)%axis) + type is (fmsDiagFullAxis_type) + axis_name = axis%get_axis_name() + end select +#endif +end function fms_get_axis_name_from_id + +!> Dumps as much data as it can from the fmsDiagObject_type. +!! Will dump any fields and files as well (see d) +subroutine dump_diag_obj( filename ) + character(len=*), intent(in), optional :: filename !< optional filename to print to, + !! otherwise prints to stdout +#ifdef use_yaml + !type(fmsDiagObject_type) :: diag_obj + type(fmsDiagFile_type), pointer :: fileptr !< pointer for traversing file list + type(fmsDiagField_type), pointer :: fieldptr !< pointer for traversing field list + integer :: i !< do loops + integer :: unit_num !< unit num of opened log file or stdout + + if( present(filename) ) then + open(newunit=unit_num, file=trim(filename), action='WRITE') + else + unit_num = stdout() + endif + if( mpp_pe() .eq. mpp_root_pe()) then + write(unit_num, *) '********** dumping diag object ***********' + write(unit_num, *) 'registered_variables:', fms_diag_object%registered_variables + write(unit_num, *) 'registered_axis:', fms_diag_object%registered_axis + write(unit_num, *) 'initialized:', fms_diag_object%initialized + write(unit_num, *) 'files_initialized:', fms_diag_object%files_initialized + write(unit_num, *) 'fields_initialized:', fms_diag_object%fields_initialized + write(unit_num, *) 'buffers_initialized:', fms_diag_object%buffers_initialized + write(unit_num, *) 'axes_initialized:', fms_diag_object%axes_initialized + write(unit_num, *) 'Files:' + if( fms_diag_object%files_initialized ) then + do i=1, SIZE(fms_diag_object%FMS_diag_files) + write(unit_num, *) 'File num:', i + fileptr => fms_diag_object%FMS_diag_files(i)%FMS_diag_file + call fileptr%dump_file_obj(unit_num) + enddo + else + write(unit_num, *) 'files not initialized' + endif + if( fms_diag_object%fields_initialized) then + do i=1, SIZE(fms_diag_object%FMS_diag_fields) + write(unit_num, *) 'Field num:', i + fieldptr => fms_diag_object%FMS_diag_fields(i) + call fieldptr%dump_field_obj(unit_num) + enddo + else + write(unit_num, *) 'fields not initialized' + endif + if( present(filename) ) close(unit_num) + endif +#else + call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml") +#endif +end subroutine + +!> @brief Allocates the output buffers of the fields corresponding to the registered variable +!! Input arguments are the field and its ID passed to routine fms_diag_accept_data() +subroutine allocate_diag_field_output_buffers(this, field_data, field_id) + class(fmsDiagObject_type), target, intent(inout) :: this !< diag object + class(*), dimension(:,:,:,:), intent(in) :: field_data !< field data + integer, intent(in) :: field_id !< Id of the field data +#ifdef use_yaml + integer :: ndims !< Number of dimensions in the input field data + integer :: buffer_id !< Buffer index of FMS_diag_buffers + integer :: num_diurnal_samples !< Number of diurnal samples from diag_yaml + integer :: axes_length(5) !< Length of each axis + integer :: i, j !< For looping + class(fmsDiagOutputBuffer_type), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class + class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields + integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable + integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer. + character(len=128), allocatable :: var_name !< Field name to initialize output buffers + logical :: is_scalar !< Flag indicating that the variable is a scalar + integer :: yaml_id !< Yaml id for the buffer + integer :: file_id !< File id for the buffer + + if (this%FMS_diag_fields(field_id)%buffer_allocated) return + + ! Determine the type of the field data + var_type = get_var_type(field_data(1, 1, 1, 1)) + + ! Get variable/field name + var_name = this%Fms_diag_fields(field_id)%get_varname() + + ! Determine dimensions of the field + is_scalar = this%FMS_diag_fields(field_id)%is_scalar() + + ! Loop over a number of fields/buffers where this variable occurs + do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids) + buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i) + file_id = this%FMS_diag_fields(field_id)%file_ids(i) + + !< Go away if the file is a subregional file and the current PE does not have any data for it + if (.not. this%FMS_diag_files(file_id)%writing_on_this_pe()) cycle + + ndims = 0 + if (.not. is_scalar) then + axis_ids = this%FMS_diag_output_buffers(buffer_id)%get_axis_ids() + ndims = size(axis_ids) + endif + + yaml_id = this%FMS_diag_output_buffers(buffer_id)%get_yaml_id() + + ptr_diag_field_yaml => diag_yaml%diag_fields(yaml_id) + num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples + + axes_length = 1 + do j = 1, ndims + axes_length(j) = this%fms_get_axis_length(axis_ids(j)) + enddo + + if (num_diurnal_samples .ne. 0) then + axes_length(ndims + 1) = num_diurnal_samples + ndims = ndims + 1 !< Add one more dimension for the diurnal axis + endif + + ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id) + call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:5), & + this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) + call ptr_diag_buffer_obj%initialize_buffer(ptr_diag_field_yaml%get_var_reduction(), var_name) + + if (allocated(axis_ids)) deallocate(axis_ids) + enddo + + this%FMS_diag_fields(field_id)%buffer_allocated = .true. +#else + call mpp_error( FATAL, "allocate_diag_field_output_buffers: "//& + "you can not use the modern diag manager without compiling with -Duse_yaml") +#endif +end subroutine allocate_diag_field_output_buffers + +!> @brief Determines if the window defined by the input bounds is a physics window. +!> @return TRUE if the window size is less then the actual field size else FALSE. +function fms_diag_compare_window(this, field, field_id, & + is_in, ie_in, js_in, je_in, ks_in, ke_in) result(is_phys_win) + class(fmsDiagObject_type), intent(in) :: this !< Diag Object + class(*), intent(in) :: field(:,:,:,:) !< Field data + integer, intent(in) :: field_id !< ID of the input field + integer, intent(in) :: is_in, js_in !< Starting field indices for the first 2 dimensions; + !< pass reconditioned indices fis and fjs + !< which are computed elsewhere. + integer, intent(in) :: ie_in, je_in !< Ending field indices for the first 2 dimensions; + !< pass reconditioned indices fie and fje + !< which are computed elsewhere. + integer, intent(in) :: ks_in, ke_in !< Starting and ending indices of the field in 3rd dimension + logical :: is_phys_win !< Return flag +#ifdef use_yaml + integer, pointer :: axis_ids(:) + integer :: total_elements + integer :: i !< For do loop + integer :: field_size + integer, allocatable :: field_shape(:) !< Shape of the field data + integer :: window_size + + !> Determine shape of the field defined by the input bounds + field_shape = shape(field(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) + + window_size = field_shape(1) * field_shape(2) * field_shape(3) + + total_elements = 1 + axis_ids => this%FMS_diag_fields(field_id)%get_axis_id() + do i=1, size(axis_ids) + total_elements = total_elements * this%fms_get_axis_length(axis_ids(i)) + enddo + + if (total_elements > window_size) then + is_phys_win = .true. + else + is_phys_win = .false. + end if +#else + is_phys_win = .false. + call mpp_error( FATAL, "fms_diag_compare_window: "//& + "you can not use the modern diag manager without compiling with -Duse_yaml") +#endif +end function fms_diag_compare_window +end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 new file mode 100644 index 0000000000..2dff49645d --- /dev/null +++ b/diag_manager/fms_diag_object_container.F90 @@ -0,0 +1,294 @@ +!*********************************************************************** +!* 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 fmsDiagField_type instances +!! +!> @author Miguel Zuniga +!! +!! fms_diag_object_container_mod defines a container for inserting, removing and +!! searching for fmsDiagField_type instances. It also defined an iterator for +!! the data in the container. The value returned by the fms_diag_object function get_id() +!! is used for search key comparison. +!! +!! 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 +#ifdef use_yaml + use fms_diag_field_object_mod, only: fmsDiagField_type + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE + + !! Since this version is based on the FDS linked list: + use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t, FmsDlListNode_t + + implicit none + + private + + !> @brief A container of fmsDiagField_type instances providing insert, remove , + !! find/search, and size public member functions. Iterator is provided by + !! the associated iterator class (see dig_obj_iterator class). + !! + !! This version does not enforce uniqueness of ID keys (I.e. it is not a set). + !! + type, public:: FmsDiagObjectContainer_t + private + 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 + + + !> @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 !< 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 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(fmsDiagField_type) , intent (in out) :: obj !< The object to insert + integer :: status !< The returned status. 0 for success. + class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator. + + 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 => 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 ) + 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 (fmsDiagField_type) !! "type is", not the (polymorphic) "class is" + rdo => gp + class default + 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 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 + +#endif +end module fms_diag_object_container_mod +!> @} +! close documentation grouping + diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 new file mode 100644 index 0000000000..b8da2b3a62 --- /dev/null +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -0,0 +1,592 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +!> @author Ryan Mulhall +!> @email ryan.mulhall@noaa.gov +!! @brief Contains buffer types and routines for the diag manager +!! +!! @description Holds buffered data for fmsDiagVars_type objects +!! buffer0-5d types extend fmsDiagBuffer_class, and upon allocation +!! are added to the module's buffer_lists depending on it's dimension +module fms_diag_output_buffer_mod +#ifdef use_yaml +use platform_mod +use iso_c_binding +use time_manager_mod, only: time_type, operator(==) +use mpp_mod, only: mpp_error, FATAL +use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8, get_base_time, MIN_VALUE, MAX_VALUE, EMPTY, & + time_min, time_max +use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t +use fms_diag_yaml_mod, only: diag_yaml +use fms_diag_bbox_mod, only: fmsDiagIbounds_type +use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max, do_time_sum_update +use fms_diag_time_utils_mod, only: diag_time_inc + +implicit none + +private + +!> holds an allocated buffer0-5d object +type :: fmsDiagOutputBuffer_type + integer :: buffer_id !< index in buffer list + integer(i4_kind) :: buffer_type !< set to allocated data type & kind value, one of i4,i8,r4,r8 + class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array + integer :: ndim !< Number of dimensions for each variable + integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer + real(r8_kind) :: weight_sum !< (x,y,z, time-of-day) used in the time averaging functions + integer, allocatable :: num_elements(:) !< used in time-averaging + integer, allocatable :: axis_ids(:) !< Axis ids for the buffer + integer :: field_id !< The id of the field the buffer belongs to + integer :: yaml_id !< The id of the yaml id the buffer belongs to + logical :: done_with_math !< .True. if done doing the math + + contains + procedure :: add_axis_ids + procedure :: get_axis_ids + procedure :: set_field_id + procedure :: get_field_id + procedure :: set_yaml_id + procedure :: get_yaml_id + procedure :: is_done_with_math + procedure :: set_done_with_math + procedure :: write_buffer + !! These are needed because otherwise the write_data calls will go into the wrong interface + procedure :: write_buffer_wrapper_netcdf + procedure :: write_buffer_wrapper_domain + procedure :: write_buffer_wrapper_u + procedure :: allocate_buffer + procedure :: initialize_buffer + procedure :: get_buffer + procedure :: flush_buffer + procedure :: do_time_none_wrapper + procedure :: do_time_min_wrapper + procedure :: do_time_max_wrapper + procedure :: do_time_sum_wrapper + +end type fmsDiagOutputBuffer_type + +! public types +public :: fmsDiagOutputBuffer_type + +! public routines +public :: fms_diag_output_buffer_init + +contains + +!!--------module routines + +!> Initializes a list of diag buffers +!> @returns true if allocation is successfull +logical function fms_diag_output_buffer_init(buffobjs, buff_list_size) + type(fmsDiagOutputBuffer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types + !! to allocate + integer, intent(in) :: buff_list_size !< size of buffer array to allocate + + if (allocated(buffobjs)) call mpp_error(FATAL,'fms_diag_buffer_init: passed in buffobjs array is already allocated') + allocate(buffobjs(buff_list_size)) + fms_diag_output_buffer_init = allocated(buffobjs) +end function fms_diag_output_buffer_init + +!!--------generic routines for any fmsDiagBuffer_class objects + +!> Setter for buffer_id for any buffer objects +subroutine set_buffer_id(this, id) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to set id for + integer, intent(in) :: id !< positive integer id to set + + this%buffer_id = id +end subroutine set_buffer_id + +!> Deallocates data fields from a buffer object. +subroutine flush_buffer(this) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< any buffer object + + this%buffer_id = diag_null + this%buffer_type = diag_null + this%ndim = diag_null + this%field_id = diag_null + this%yaml_id = diag_null + if (allocated(this%buffer)) deallocate(this%buffer) + if (allocated(this%buffer_dims)) deallocate(this%buffer_dims) + if (allocated(this%num_elements)) deallocate(this%num_elements) + if (allocated(this%axis_ids)) deallocate(this%axis_ids) +end subroutine flush_buffer + +!> Allocates a 5D buffer to given buff_type. +subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurnal_samples) + class(fmsDiagOutputBuffer_type), intent(inout), target :: this !< 5D buffer object + class(*), intent(in) :: buff_type !< allocates to the type of buff_type + integer, intent(in) :: ndim !< Number of dimension + integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes + character(len=*), intent(in) :: field_name !< field name for error output + integer, optional, intent(in) :: diurnal_samples !< number of diurnal samples + + integer :: n_samples !< number of diurnal samples, defaults to 1 + + if(present(diurnal_samples)) then + n_samples = diurnal_samples + else + n_samples = 1 + endif + + this%ndim =ndim + if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer: buffer already allocated for field:" // & + field_name) + select type (buff_type) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + this%weight_sum = 0.0_r4_kind + this%buffer_type = i4 + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + this%weight_sum = 0.0_r8_kind + this%buffer_type = i8 + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + this%weight_sum = 0.0_r4_kind + this%buffer_type = r4 + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + this%weight_sum = 0.0_r8_kind + this%buffer_type = r8 + class default + call mpp_error("allocate_buffer", & + "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & + "for field:" // field_name, FATAL) + end select + allocate(this%num_elements(n_samples)) + this%num_elements = 0 + this%done_with_math = .false. + allocate(this%buffer_dims(5)) + this%buffer_dims(1) = buff_sizes(1) + this%buffer_dims(2) = buff_sizes(2) + this%buffer_dims(3) = buff_sizes(3) + this%buffer_dims(4) = buff_sizes(4) + this%buffer_dims(5) = buff_sizes(5) +end subroutine allocate_buffer + +!> Get routine for 5D buffers. +!! Sets the buff_out argument to the integer or real array currently stored in the buffer. +subroutine get_buffer (this, buff_out, field_name) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< 5d allocated buffer object + class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data + !! must be the same size as the allocated buffer + character(len=*), intent(in) :: field_name !< field name for error output + + integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer + + if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_buffer: buffer not yet allocated for field:' & + & // field_name) + buff_size(1) = size(this%buffer,1) + buff_size(2) = size(this%buffer,2) + buff_size(3) = size(this%buffer,3) + buff_size(4) = size(this%buffer,4) + buff_size(5) = size(this%buffer,5) + + select type (buff=>this%buffer) + type is (real(r4_kind)) + allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (real(r8_kind)) + allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (integer(i4_kind)) + allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (integer(i8_kind)) + allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + class default + call mpp_error(FATAL, "get_buffer: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)."& + //"field name: "// field_name) + end select +end subroutine + +!> @brief Initializes a buffer based on the reduction method +subroutine initialize_buffer (this, reduction_method, field_name) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< allocated 5D buffer object + integer, intent(in) :: reduction_method !< The reduction method for the field + character(len=*), intent(in) :: field_name !< field name for error output + + if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer: field:'// field_name // & + 'buffer not yet allocated, allocate_buffer() must be called on this object first.') + + select type(buff => this%buffer) + type is(real(r8_kind)) + select case (reduction_method) + case (time_min) + buff = real(MIN_VALUE, kind=r8_kind) + case (time_max) + buff = real(MAX_VALUE, kind=r8_kind) + case default + buff = real(EMPTY, kind=r8_kind) + end select + type is(real(r4_kind)) + select case (reduction_method) + case (time_min) + buff = real(MIN_VALUE, kind=r4_kind) + case (time_max) + buff = real(MAX_VALUE, kind=r4_kind) + case default + buff = real(EMPTY, kind=r4_kind) + end select + type is(integer(i8_kind)) + select case (reduction_method) + case (time_min) + buff = int(MIN_VALUE, kind=i8_kind) + case (time_max) + buff = int(MAX_VALUE, kind=i8_kind) + case default + buff = int(EMPTY, kind=i8_kind) + end select + type is(integer(i4_kind)) + select case (reduction_method) + case (time_min) + buff = int(MIN_VALUE, kind=i4_kind) + case (time_max) + buff = int(MAX_VALUE, kind=i4_kind) + case default + buff = int(EMPTY, kind=i4_kind) + end select + class default + call mpp_error(FATAL, 'initialize buffer_5d: buffer allocated to invalid data type, this shouldnt happen') + end select + +end subroutine initialize_buffer + +!> @brief Adds the axis ids to the buffer object +subroutine add_axis_ids(this, axis_ids) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: axis_ids(:) !< Axis ids to add + + this%axis_ids = axis_ids +end subroutine + +!> @brief Get the axis_ids for the buffer +!! @return Axis_ids, if the buffer doesn't have axis ids it returns diag_null +function get_axis_ids(this) & + result(res) + + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, allocatable :: res(:) + + if (allocated(this%axis_ids)) then + res = this%axis_ids + else + allocate(res(1)) + res = diag_null + endif +end function + +!> @brief Get the field id of the buffer +!! @return the field id of the buffer +function get_field_id(this) & + result(res) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object + integer :: res + + res = this%field_id +end function get_field_id + +!> @brief set the field id of the buffer +subroutine set_field_id(this, field_id) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: field_id !< field id of the buffer + + this%field_id = field_id +end subroutine set_field_id + +!> @brief set the field id of the buffer +subroutine set_yaml_id(this, yaml_id) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: yaml_id !< yaml id of the buffer + + this%yaml_id = yaml_id +end subroutine set_yaml_id + +!> @brief Determine if finished with math +!! @return this%done_with_math +function is_done_with_math(this) & + result(res) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object + logical :: res + + res = this%done_with_math +end function is_done_with_math + +!> @brief Set done_with_math to .true. +subroutine set_done_with_math(this) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer :: res + + this%done_with_math = .true. +end subroutine set_done_with_math + +!> @brief Get the yaml id of the buffer +!! @return the yaml id of the buffer +function get_yaml_id(this) & + result(res) + + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object + integer :: res + + res = this%yaml_id +end function get_yaml_id + +!> @brief Write the buffer to the file +subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + select type(fms2io_fileobj) + type is (FmsNetcdfFile_t) + call this%write_buffer_wrapper_netcdf(fms2io_fileobj, unlim_dim_level=unlim_dim_level) + type is (FmsNetcdfDomainFile_t) + call this%write_buffer_wrapper_domain(fms2io_fileobj, unlim_dim_level=unlim_dim_level) + type is (FmsNetcdfUnstructuredDomainFile_t) + call this%write_buffer_wrapper_u(fms2io_fileobj, unlim_dim_level=unlim_dim_level) + class default + call mpp_error(FATAL, "The file "//trim(fms2io_fileobj%path)//" is not one of the accepted types"//& + " only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.") + end select + + call this%initialize_buffer(diag_yaml%diag_fields(this%yaml_id)%get_var_reduction(), & + diag_yaml%diag_fields(this%yaml_id)%get_var_outname()) + !TODO Set the counters back to 0 +end subroutine write_buffer + +!> @brief Write the buffer to the FmsNetcdfFile_t fms2io_fileobj +subroutine write_buffer_wrapper_netcdf(this, fms2io_fileobj, unlim_dim_level) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select case(this%ndim) + case (0) + call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) + end select +end subroutine write_buffer_wrapper_netcdf + +!> @brief Write the buffer to the FmsNetcdfDomainFile_t fms2io_fileobj +subroutine write_buffer_wrapper_domain(this, fms2io_fileobj, unlim_dim_level) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select case(this%ndim) + case (0) + call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) + end select +end subroutine write_buffer_wrapper_domain + +!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fms2io_fileobj +subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select case(this%ndim) + case (0) + call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) + end select +end subroutine write_buffer_wrapper_u + +!> @brief Does the time_none reduction method on the buffer object +!! @return Error message if the math was not successful +function do_time_none_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) & + result(err_msg) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field + logical, intent(in) :: is_masked !< .True. if the field has a mask + real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked + character(len=50) :: err_msg + + !TODO This will be expanded for integers + err_msg = "" + select type (output_buffer => this%buffer) + type is (real(kind=r8_kind)) + select type (field_data) + type is (real(kind=r8_kind)) + call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) + class default + err_msg="do_time_none_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)" + end select + type is (real(kind=r4_kind)) + select type (field_data) + type is (real(kind=r4_kind)) + call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, & + real(missing_value, kind=r4_kind)) + class default + err_msg="do_time_none_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)" + end select + end select +end function do_time_none_wrapper + +!> @brief Does the time_min reduction method on the buffer object +!! @return Error message if the math was not successful +function do_time_min_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) & + result(err_msg) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field + logical, intent(in) :: is_masked !< .True. if the field has a mask + real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked + character(len=50) :: err_msg + + !TODO This will be expanded for integers + err_msg = "" + select type (output_buffer => this%buffer) + type is (real(kind=r8_kind)) + select type (field_data) + type is (real(kind=r8_kind)) + call do_time_min(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) + class default + err_msg="do_time_min_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)" + end select + type is (real(kind=r4_kind)) + select type (field_data) + type is (real(kind=r4_kind)) + call do_time_min(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, & + real(missing_value, kind=r4_kind)) + class default + err_msg="do_time_min_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)" + end select + end select +end function do_time_min_wrapper + +!> @brief Does the time_min reduction method on the buffer object +!! @return Error message if the math was not successful +function do_time_max_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) & + result(err_msg) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field + logical, intent(in) :: is_masked !< .True. if the field has a mask + real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked + character(len=50) :: err_msg + + !TODO This will be expanded for integers + err_msg = "" + select type (output_buffer => this%buffer) + type is (real(kind=r8_kind)) + select type (field_data) + type is (real(kind=r8_kind)) + call do_time_max(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) + class default + err_msg="do_time_max_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)" + end select + type is (real(kind=r4_kind)) + select type (field_data) + type is (real(kind=r4_kind)) + call do_time_max(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, & + real(missing_value, kind=r4_kind)) + class default + err_msg="do_time_max_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)" + end select + end select +end function do_time_max_wrapper + +!> @brief Does the time_sum reduction method on the buffer object +!! @return Error message if the math was not successful +function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) & + result(err_msg) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field + logical, intent(in) :: is_masked !< .True. if the field has a mask + real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked + character(len=50) :: err_msg + + !TODO This will be expanded for integers + err_msg = "" + select type (output_buffer => this%buffer) + type is (real(kind=r8_kind)) + select type (field_data) + type is (real(kind=r8_kind)) + call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, & + bounds_in, bounds_out, missing_value) + class default + err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)" + end select + type is (real(kind=r4_kind)) + select type (field_data) + type is (real(kind=r4_kind)) + call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, & + real(missing_value, kind=r4_kind)) + class default + err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)" + end select + class default + err_msg="do_time_sum_wrapper::the output buffer is not a valid type, must be real(r8_kind) or real(r4_kind)" + end select +end function do_time_sum_wrapper +#endif +end module fms_diag_output_buffer_mod diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 new file mode 100644 index 0000000000..c3d939b0f6 --- /dev/null +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -0,0 +1,160 @@ +!*********************************************************************** +!* 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_reduction_methods_mod fms_diag_reduction_methods_mod +!> @ingroup diag_manager +!! @brief fms_diag_reduction_methods_mod contains routines that are meant to be used for +!! error checking and setting up to do the reduction methods + +!> @file +!> @brief File for @ref fms_diag_reduction_methods_mod + +!> @addtogroup fms_diag_reduction_methods_mod +!> @{ +module fms_diag_reduction_methods_mod + use platform_mod, only: r8_kind, r4_kind + use fms_diag_bbox_mod, only: fmsDiagIbounds_type + use mpp_mod + implicit none + private + + public :: check_indices_order, init_mask, set_weight + public :: do_time_none, do_time_min, do_time_max, do_time_sum_update + + !> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc + !TODO This needs to be extended to integers + interface do_time_none + module procedure do_time_none_r4, do_time_none_r8 + end interface do_time_none + + !> @brief Does the time_min reduction method. See include/fms_diag_reduction_methods.inc + !TODO This needs to be extended to integers + interface do_time_min + module procedure do_time_min_r4, do_time_min_r8 + end interface do_time_min + + !> @brief Does the time_max reduction method. See include/fms_diag_reduction_methods.inc + !TODO This needs to be extended to integers + interface do_time_max + module procedure do_time_max_r4, do_time_max_r8 + end interface do_time_max + + !> @brief Sum update updates the buffer for any reductions that involve summation + !! (ie. time_sum, avg, rms, pow) + !!TODO This needs to be extended to integers + interface do_time_sum_update + module procedure do_time_sum_update_r4, do_time_sum_update_r8 + end interface + + contains + + !> @brief Checks improper combinations of is, ie, js, and je. + !! @return The error message, empty string if no errors were found + !> @note accept_data works in either one or another of two modes. + !! 1. Input field is a window (e.g. FMS physics) + !! 2. Input field includes halo data + !! It cannot handle a window of data that has halos. + !! (A field with no windows or halos can be thought of as a special case of either mode.) + !! The logic for indexing is quite different for these two modes, but is not clearly separated. + !! If both the beggining and ending indices are present, then field is assumed to have halos. + !! If only beggining indices are present, then field is assumed to be a window. + !> @par + !! There are a number of ways a user could mess up this logic, depending on the combination + !! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. + pure function check_indices_order(is_in, ie_in, js_in, je_in) & + result(error_msg) + integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data() + character(len=128) :: error_msg !< An error message used only for testing purpose!!! + + error_msg = "" + IF ( PRESENT(ie_in) ) THEN + IF ( .NOT.PRESENT(is_in) ) THEN + error_msg = 'ie_in present without is_in' + return + END IF + IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN + error_msg = 'is_in and ie_in present, but js_in present without je_in' + return + END IF + END IF + + IF ( PRESENT(je_in) ) THEN + IF ( .NOT.PRESENT(js_in) ) THEN + error_msg = 'je_in present without js_in' + return + END IF + IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN + error_msg = 'js_in and je_in present, but is_in present without ie_in' + return + END IF + END IF + end function check_indices_order + + !> @brief Sets the logical mask based on mask or rmask + !> @return logical mask + function init_mask(rmask, mask, field) & + result(oor_mask) + LOGICAL, DIMENSION(:,:,:,:), allocatable, INTENT(in) :: mask !< The location of the mask + CLASS(*), DIMENSION(:,:,:,:), allocatable, INTENT(in) :: rmask !< The masking values + CLASS(*), DIMENSION(:,:,:,:), intent(in) :: field !< Field_data + + logical, allocatable, dimension(:,:,:,:) :: oor_mask !< mask + + ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4))) + oor_mask = .true. + + if (allocated(mask)) then + oor_mask = mask + elseif (allocated(rmask)) then + select type (rmask) + type is (real(kind=r8_kind)) + WHERE (rmask < 0.5_r8_kind) oor_mask = .FALSE. + type is (real(kind=r4_kind)) + WHERE (rmask < 0.5_r4_kind) oor_mask = .FALSE. + end select + endif + + end function init_mask + + !> @brief Sets the weight based on the weight passed into send_data (1.0_r8_kind if the weight is not passed in) + !! The weight will be saved as an r8 and converted to r4 as needed + !! @return weight to use when averaging + pure function set_weight(weight) & + result(out_weight) + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight use when averaging + + real(kind=r8_kind) :: out_weight + + out_weight = 1.0_r8_kind + if (present(weight)) then + select type(weight) + type is (real(kind=r8_kind)) + out_weight = real(weight, kind = r8_kind) + type is (real(kind=r4_kind)) + out_Weight = real(weight, kind = r8_kind) + end select + endif + end function set_weight + +#include "fms_diag_reduction_methods_r4.fh" +#include "fms_diag_reduction_methods_r8.fh" + +end module fms_diag_reduction_methods_mod +!> @} +! close documentation grouping \ No newline at end of file diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90 new file mode 100644 index 0000000000..efcf4690f9 --- /dev/null +++ b/diag_manager/fms_diag_time_utils.F90 @@ -0,0 +1,369 @@ +!*********************************************************************** +!* 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_time_utils_mod fms_diag_time_utils_mod +!> @ingroup diag_manager +!! @brief fms_diag_time_utils contains functions and subroutines necessary for the +!! diag_manager_mod related to time handling. +!! @author Uriel Ramirez + +!> @addtogroup fms_diag_time_utils_mod +!> @{ +module fms_diag_time_utils_mod + +use time_manager_mod, only: time_type, increment_date, increment_time, get_calendar_type, NO_CALENDAR, leap_year, & + get_date, get_time, operator(>), operator(<), operator(-), set_date +use diag_data_mod, only: END_OF_RUN, EVERY_TIME, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, & + DIAG_YEARS, use_clock_average +USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE +use fms_mod, only: fms_error_handler +use mpp_mod, only: mpp_error, FATAL + +implicit none +private + +public :: diag_time_inc +public :: get_time_string +public :: get_date_dif + +contains + + !> @brief Return the next time data/file is to be written based on the frequency and units. + TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg) + TYPE(time_type), INTENT(in) :: time !< Current model time. + INTEGER, INTENT(in) :: output_freq !< Output frequency number value. + INTEGER, INTENT(in) :: output_units !< Output frequency unit. + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message. + !! An empty string indicates the next output + !! time was found successfully. + + if (use_clock_average) then + diag_time_inc = diag_clock_time_inc(time, output_freq, output_units, err_msg) + else + diag_time_inc = diag_forecast_time_inc(time, output_freq, output_units, err_msg) + endif + end function diag_time_inc + + !> @brief Determine the next time data/file is to be written based on the frequency and units using the clock. + !! For example, if doing daily averages and the input time is day1_hour3, the output time will be day2_hour0. + !! @return the next time data/file is to be written + TYPE(time_type) FUNCTION diag_clock_time_inc(time, output_freq, output_units, err_msg) + TYPE(time_type), INTENT(in) :: time !< Current model time. + INTEGER, INTENT(in) :: output_freq !< Output frequency number value. + INTEGER, INTENT(in) :: output_units !< Output frequency unit. + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message. + !! An empty string indicates the next output + !! time was found successfully. + CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message + integer :: cyear !< The current year stored in the time type + integer :: cmonth !< The current month stored in the time type + integer :: cday !< The current day stored in the time type + integer :: chour !< The current hour stored in the time type + integer :: cmin !< The current minute stored in the time type + integer :: csecond !< The current second stored in the time type + type(time_type) :: my_time !< Time set at the begining of the + + IF ( PRESENT(err_msg) ) err_msg = '' + error_message_local = '' + + IF ( get_calendar_type() == NO_CALENDAR) then + error_message_local = 'If using use_clock_average =.TRUE., your calendar must be set.' + IF ( fms_error_handler('diag_clock_time_inc',error_message_local,err_msg) ) RETURN + endif + + ! special values for output frequency are -1 for output at end of run + ! and 0 for every timestep. Need to check for these here? + ! Return zero time increment, hopefully this value is never used + IF ( output_freq == END_OF_RUN .OR. output_freq == EVERY_TIME ) THEN + diag_clock_time_inc = time + RETURN + END IF + + call get_date(Time, cyear, cmonth, cday, chour, cmin, csecond) + + select case (output_units) + case (DIAG_SECONDS) + my_time = set_date(cyear, cmonth, cday, chour, cmin, csecond) !< set my_time to the begining of the hour + diag_clock_time_inc = increment_date(my_time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local) + case (DIAG_MINUTES) + my_time = set_date(cyear, cmonth, cday, chour, cmin, 0) !< set my_time to the begining of the hour + diag_clock_time_inc = increment_date(my_time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local) + case (DIAG_HOURS) + my_time = set_date(cyear, cmonth, cday, chour, 0, 0) !< set my_time to the begining of the hour + diag_clock_time_inc = increment_date(my_time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local) + case (DIAG_DAYS) + my_time = set_date(cyear, cmonth, cday, 0, 0, 0) !< set my_time to the begining of the day + diag_clock_time_inc = increment_date(my_time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local) + case (DIAG_MONTHS) + my_time = set_date(cyear, cmonth, 1, 0, 0, 0) !< set my_time to the begining of the month + diag_clock_time_inc = increment_date(my_time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local) + case (DIAG_YEARS) + my_time = set_date(cyear, 1, 1, 0, 0, 0) !< set my_time to the begining of the year + diag_clock_time_inc = increment_date(my_time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local) + end select + + end function diag_clock_time_inc + + !> @brief Determine the next time data/file is to be written based on the frequency and units using forecast time. + !! For example, if doing daily averages and the input time is day1_hour3, the output time will be day2_hour3. + !! @return the next time data/file is to be written + TYPE(time_type) FUNCTION diag_forecast_time_inc(time, output_freq, output_units, err_msg) + TYPE(time_type), INTENT(in) :: time !< Current model time. + INTEGER, INTENT(in) :: output_freq !< Output frequency number value. + INTEGER, INTENT(in) :: output_units !< Output frequency unit. + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message. + !! An empty string indicates the next output + !! time was found successfully. + + CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message + + IF ( PRESENT(err_msg) ) err_msg = '' + error_message_local = '' + + ! special values for output frequency are -1 for output at end of run + ! and 0 for every timestep. Need to check for these here? + ! Return zero time increment, hopefully this value is never used + IF ( output_freq == END_OF_RUN .OR. output_freq == EVERY_TIME ) THEN + diag_forecast_time_inc = time + RETURN + END IF + + ! Make sure calendar was not set after initialization + IF ( output_units == DIAG_SECONDS ) THEN + IF ( get_calendar_type() == NO_CALENDAR ) THEN + diag_forecast_time_inc = increment_time(time, output_freq, 0, err_msg=error_message_local) + ELSE + diag_forecast_time_inc = increment_date(time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local) + END IF + ELSE IF ( output_units == DIAG_MINUTES ) THEN + IF ( get_calendar_type() == NO_CALENDAR ) THEN + diag_forecast_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_MINUTE), 0, & + &err_msg=error_message_local) + ELSE + diag_forecast_time_inc = increment_date(time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local) + END IF + ELSE IF ( output_units == DIAG_HOURS ) THEN + IF ( get_calendar_type() == NO_CALENDAR ) THEN + diag_forecast_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_HOUR), 0, & + &err_msg=error_message_local) + ELSE + diag_forecast_time_inc = increment_date(time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local) + END IF + ELSE IF ( output_units == DIAG_DAYS ) THEN + IF (get_calendar_type() == NO_CALENDAR) THEN + diag_forecast_time_inc = increment_time(time, 0, output_freq, err_msg=error_message_local) + ELSE + diag_forecast_time_inc = increment_date(time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local) + END IF + ELSE IF ( output_units == DIAG_MONTHS ) THEN + IF (get_calendar_type() == NO_CALENDAR) THEN + error_message_local = 'output units of months NOT allowed with no calendar' + ELSE + diag_forecast_time_inc = increment_date(time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local) + END IF + ELSE IF ( output_units == DIAG_YEARS ) THEN + IF ( get_calendar_type() == NO_CALENDAR ) THEN + error_message_local = 'output units of years NOT allowed with no calendar' + ELSE + diag_forecast_time_inc = increment_date(time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local) + END IF + ELSE + error_message_local = 'illegal output units' + END IF + + IF ( error_message_local /= '' ) THEN + IF ( fms_error_handler('diag_forecast_time_inc',error_message_local,err_msg) ) RETURN + END IF + END FUNCTION diag_forecast_time_inc + + !> @brief This function determines a string based on current time. + !! This string is used as suffix in output file name + !! @return Character(len=128) get_time_string + CHARACTER(len=128) FUNCTION get_time_string(filename, current_time) + CHARACTER(len=*), INTENT(in) :: filename !< File name. + TYPE(time_type), INTENT(in) :: current_time !< Current model time. + + INTEGER :: yr1 !< get from current time + INTEGER :: mo1 !< get from current time + INTEGER :: dy1 !< get from current time + INTEGER :: hr1 !< get from current time + INTEGER :: mi1 !< get from current time + INTEGER :: sc1 !< get from current time + INTEGER :: yr2 !< for computing next_level time unit + INTEGER :: dy2 !< for computing next_level time unit + INTEGER :: hr2 !< for computing next_level time unit + INTEGER :: mi2 !< for computing next_level time unit + INTEGER :: yr1_s !< actual values to write string + INTEGER :: mo1_s !< actual values to write string + INTEGER :: dy1_s !< actual values to write string + INTEGER :: hr1_s !< actual values to write string + INTEGER :: mi1_s !< actual values to write string + INTEGER :: sc1_s !< actual values to write string + INTEGER :: abs_day !< component of current_time + INTEGER :: abs_sec !< component of current_time + INTEGER :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER :: julian_day, i, position, len, first_percent + CHARACTER(len=1) :: width !< width of the field in format write + CHARACTER(len=10) :: format + CHARACTER(len=20) :: yr !< string of current time (output) + CHARACTER(len=20) :: mo !< string of current time (output) + CHARACTER(len=20) :: dy !< string of current time (output) + CHARACTER(len=20) :: hr !< string of current time (output) + CHARACTER(len=20) :: mi !< string of current time (output) + CHARACTER(len=20) :: sc !< string of current time (output) + CHARACTER(len=128) :: filetail + + format = '("_",i*.*)' + CALL get_date(current_time, yr1, mo1, dy1, hr1, mi1, sc1) + len = LEN_TRIM(filename) + first_percent = INDEX(filename, '%') + filetail = filename(first_percent:len) + ! compute year string + position = INDEX(filetail, 'yr') + IF ( position > 0 ) THEN + width = filetail(position-1:position-1) + yr1_s = yr1 + format(7:9) = width//'.'//width + WRITE(yr, format) yr1_s + yr2 = 0 + ELSE + yr = ' ' + yr2 = yr1 - 1 + END IF + ! compute month string + position = INDEX(filetail, 'mo') + IF ( position > 0 ) THEN + width = filetail(position-1:position-1) + mo1_s = yr2*12 + mo1 + format(7:9) = width//'.'//width + WRITE(mo, format) mo1_s + ELSE + mo = ' ' + END IF + ! compute day string + IF ( LEN_TRIM(mo) > 0 ) THEN ! month present + dy1_s = dy1 + dy2 = dy1_s - 1 + ELSE IF ( LEN_TRIM(yr) >0 ) THEN ! no month, year present + ! compute julian day + IF ( mo1 == 1 ) THEN + dy1_s = dy1 + ELSE + julian_day = 0 + DO i = 1, mo1-1 + julian_day = julian_day + days_per_month(i) + END DO + IF ( leap_year(current_time) .AND. mo1 > 2 ) julian_day = julian_day + 1 + julian_day = julian_day + dy1 + dy1_s = julian_day + END IF + dy2 = dy1_s - 1 + ELSE ! no month, no year + CALL get_time(current_time, abs_sec, abs_day) + dy1_s = abs_day + dy2 = dy1_s + END IF + position = INDEX(filetail, 'dy') + IF ( position > 0 ) THEN + width = filetail(position-1:position-1) + FORMAT(7:9) = width//'.'//width + WRITE(dy, FORMAT) dy1_s + ELSE + dy = ' ' + END IF + ! compute hour string + IF ( LEN_TRIM(dy) > 0 ) THEN + hr1_s = hr1 + ELSE + hr1_s = dy2*24 + hr1 + END IF + hr2 = hr1_s + position = INDEX(filetail, 'hr') + IF ( position > 0 ) THEN + width = filetail(position-1:position-1) + format(7:9) = width//'.'//width + WRITE(hr, format) hr1_s + ELSE + hr = ' ' + END IF + ! compute minute string + IF ( LEN_TRIM(hr) > 0 ) THEN + mi1_s = mi1 + ELSE + mi1_s = hr2*60 + mi1 + END IF + mi2 = mi1_s + position = INDEX(filetail, 'mi') + IF(position>0) THEN + width = filetail(position-1:position-1) + format(7:9) = width//'.'//width + WRITE(mi, format) mi1_s + ELSE + mi = ' ' + END IF + ! compute second string + IF ( LEN_TRIM(mi) > 0 ) THEN + sc1_s = sc1 + ELSE + sc1_s = NINT(mi2*SECONDS_PER_MINUTE) + sc1 + END IF + position = INDEX(filetail, 'sc') + IF ( position > 0 ) THEN + width = filetail(position-1:position-1) + format(7:9) = width//'.'//width + WRITE(sc, format) sc1_s + ELSE + sc = ' ' + ENDIF + get_time_string = TRIM(yr)//TRIM(mo)//TRIM(dy)//TRIM(hr)//TRIM(mi)//TRIM(sc) + END FUNCTION get_time_string + + !> @brief Return the difference between two times in units. + !! @return Real get_data_dif + REAL FUNCTION get_date_dif(t2, t1, units) + TYPE(time_type), INTENT(in) :: t2 !< Most recent time. + TYPE(time_type), INTENT(in) :: t1 !< Most distant time. + INTEGER, INTENT(in) :: units !< Unit of return value. + + INTEGER :: dif_seconds, dif_days + TYPE(time_type) :: dif_time + + IF ( t2 < t1 ) CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif '//& + &'in variable t2 is less than in variable t1') + + dif_time = t2 - t1 + + CALL get_time(dif_time, dif_seconds, dif_days) + + IF ( units == DIAG_SECONDS ) THEN + get_date_dif = dif_seconds + SECONDS_PER_DAY * dif_days + ELSE IF ( units == DIAG_MINUTES ) THEN + get_date_dif = 1440 * dif_days + dif_seconds / SECONDS_PER_MINUTE + ELSE IF ( units == DIAG_HOURS ) THEN + get_date_dif = 24 * dif_days + dif_seconds / SECONDS_PER_HOUR + ELSE IF ( units == DIAG_DAYS ) THEN + get_date_dif = dif_days + dif_seconds / SECONDS_PER_DAY + ELSE IF ( units == DIAG_MONTHS ) THEN + CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif months not supported as output units') + ELSE IF ( units == DIAG_YEARS ) THEN + CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif years not supported as output units') + ELSE + CALL mpp_error(FATAL, 'diag_util_mod::diag_date_dif illegal time units') + END IF + END FUNCTION get_date_dif +end module fms_diag_time_utils_mod diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 new file mode 100644 index 0000000000..20db697472 --- /dev/null +++ b/diag_manager/fms_diag_yaml.F90 @@ -0,0 +1,1527 @@ +!*********************************************************************** +!* 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 diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, & + index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, & + DIAG_MONTHS, DIAG_YEARS, time_average, time_rms, time_max, time_min, time_sum, & + time_diurnal, time_power, time_none, r8, i8, r4, i4, DIAG_NOT_REGISTERED, & + middle_time, begin_time, end_time, MAX_STR_LEN +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, mpp_pe, mpp_root_pe, stdout +use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char +use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique +use platform_mod, only: r4_kind, i4_kind +use fms_mod, only: lowercase + +implicit none + +private + +public :: diag_yaml +public :: diag_yaml_object_init, diag_yaml_object_end +public :: diagYamlObject_type, get_diag_yaml_obj, subRegion_type +public :: diagYamlFiles_type, diagYamlFilesVar_type +public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id +public :: get_diag_field_ids +public :: dump_diag_yaml_obj +!> @} + +integer, parameter :: basedate_size = 6 +integer, parameter :: NUM_SUB_REGION_ARRAY = 8 +integer, parameter :: MAX_FREQ = 12 + + +!> @brief type to hold an array of sorted diag_fiels +type varList_type + character(len=255), allocatable :: var_name(:) !< Array of diag_field + type(c_ptr), allocatable :: var_pointer(:) !< Array of pointers + integer, allocatable :: diag_field_indices(:) !< Index of the field in the diag_field array +end type + +!> @brief type to hold an array of sorted diag_files +type fileList_type + character(len=255), allocatable :: file_name(:) !< Array of diag_field + type(c_ptr), allocatable :: file_pointer(:) !< Array of pointers + integer, allocatable :: diag_file_indices(:) !< Index of the file in the diag_file array +end type + +!> @brief type to hold the sub region information about a file +type subRegion_type + INTEGER :: grid_type !< Flag indicating the type of region, + !! acceptable values are latlon_gridtype, index_gridtype, + !! null_gridtype + class(*), allocatable :: corners(:,:)!< (x, y) coordinates of the four corner of the region + 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 + private + character (len=:), allocatable :: file_fname !< file name + integer :: file_frequnit(MAX_FREQ) !< the frequency unit (DIAG_SECONDS, + !! DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, + !! DIAG_YEARS) + integer :: file_freq(MAX_FREQ) !< the frequency of data + integer :: file_timeunit !< The unit of time (DIAG_SECONDS, + !! DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, + !! DIAG_YEARS) + character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension + type(subRegion_type) :: file_sub_region !< type containing info about the subregion + integer :: file_new_file_freq(MAX_FREQ) !< Frequency for closing the existing file + integer :: file_new_file_freq_units(MAX_FREQ) !< Time units for creating a new file. + !! Required if “new_file_freq” used + !! (DIAG_SECONDS, DIAG_MINUTES, & + !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS) + character (len=:), allocatable :: file_start_time !< Time to start the file for the + !! first time. Requires “new_file_freq” + integer :: filename_time !< The time to use when setting the name of + !! new files: begin, middle, or end of the + !! time_bounds + integer :: file_duration(MAX_FREQ) !< 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. + integer :: file_duration_units(MAX_FREQ) !< The file duration units + !! (DIAG_SECONDS, DIAG_MINUTES, & + !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS) + integer :: current_new_file_freq_index !< The index of the new_file_freq array + !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length + character (len=MAX_STR_LEN), allocatable :: file_varlist(:) !< An array of variable names + !! within a file + character (len=MAX_STR_LEN), 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, public :: size_file_varlist + procedure, public :: get_file_fname + procedure, public :: get_file_frequnit + procedure, public :: get_file_freq + procedure, public :: get_file_timeunit + procedure, public :: get_file_unlimdim + procedure, public :: get_file_sub_region + procedure, public :: get_file_new_file_freq + procedure, public :: get_file_new_file_freq_units + procedure, public :: get_file_start_time + procedure, public :: get_file_duration + procedure, public :: get_file_duration_units + procedure, public :: get_file_varlist + procedure, public :: get_file_global_meta + procedure, public :: get_filename_time + procedure, public :: 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, public :: has_file_fname + procedure, public :: has_file_frequnit + procedure, public :: has_file_freq + procedure, public :: has_file_timeunit + procedure, public :: has_file_unlimdim + procedure, public :: has_file_sub_region + procedure, public :: has_file_new_file_freq + procedure, public :: has_file_new_file_freq_units + procedure, public :: has_file_start_time + procedure, public :: has_file_duration + procedure, public :: has_file_duration_units + procedure, public :: has_file_varlist + procedure, public :: has_file_global_meta + procedure, public :: increase_new_file_freq_index +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 + integer , private, allocatable :: var_reduction !< Reduction to be done on var + !! time_average, time_rms, time_max, + !! time_min, time_sum, time_diurnal, time_power + character (len=:), private, allocatable :: var_module !< The module that th variable is in + integer , private, allocatable :: var_kind !< The type/kind of the variable + 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 + real(kind=r4_kind), private :: var_zbounds(2) !< The z axis limits [vert_min, vert_max] + integer , private :: n_diurnal !< Number of diurnal samples + !! 0 if var_reduction is not "diurnalXX" + integer , private :: pow_value !< The power value + !! 0 if pow_value is not "powXX" + + !< 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_kind + procedure :: get_var_outname + procedure :: get_var_longname + procedure :: get_var_units + procedure :: get_var_zbounds + procedure :: get_var_attributes + procedure :: get_n_diurnal + procedure :: get_pow_value + procedure :: is_var_attributes + + procedure :: has_var_fname + procedure :: has_var_varname + procedure :: has_var_reduction + procedure :: has_var_module + procedure :: has_var_kind + procedure :: has_var_outname + procedure :: has_var_longname + procedure :: has_var_units + procedure :: has_var_zbounds + procedure :: has_var_attributes + procedure :: has_n_diurnal + procedure :: has_pow_value + +end type diagYamlFilesVar_type + +!> @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, public, dimension (:) :: diag_files!< History file info + type(diagYamlFilesVar_type), allocatable, public, dimension (:) :: diag_fields !< Diag fields info + contains + procedure :: size_diag_files + + 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 + procedure :: get_diag_field_from_id + + procedure :: has_diag_title + procedure :: has_diag_basedate + procedure :: has_diag_files + procedure :: has_diag_fields + +end type diagYamlObject_type + +type (diagYamlObject_type), target :: diag_yaml !< Obj containing the contents of the diag_table.yaml +type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml +type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml + +logical, private :: diag_yaml_module_initialized = .false. + + +!> @addtogroup fms_diag_yaml_mod +!> @{ +contains + +!> @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 (this) & +result (diag_basedate) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return + + diag_basedate = this%diag_basedate +end function get_basedate + +!> @brief Find the number of files listed in the diag yaml +!! @return the number of files in the diag yaml +pure integer function size_diag_files(this) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + if (this%has_diag_files()) then + size_diag_files = size(this%diag_files) + else + size_diag_files = 0 + endif +end function size_diag_files + +!> @brief get the title of a diag_yaml type +!! @return the title of the diag table as an allocated string +pure function get_title (this) & + result (diag_title) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + character(len=:),allocatable :: diag_title !< Basedate array result to return + + diag_title = this%diag_title +end function get_title + +!> @brief get the diag_files of a diag_yaml type +!! @return the diag_files +function get_diag_files(this) & +result(diag_files) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< History file info + + diag_files = this%diag_files +end function get_diag_files + +!> @brief Get the diag_field yaml corresponding to a yaml_id +!! @return Pointer to the diag_field yaml entry +function get_diag_field_from_id(this, yaml_id) & + result(diag_field) + class (diagYamlObject_type), target, intent(in) :: this !< The diag_yaml + integer, intent(in) :: yaml_id !< Yaml id + + type(diagYamlFilesVar_type), pointer :: diag_field !< Diag fields info + + if (yaml_id .eq. DIAG_NOT_REGISTERED) call mpp_error(FATAL, & + "Diag_manager: The yaml id for this field is not is not set") + + diag_field => this%diag_fields(variable_list%diag_field_indices(yaml_id)) + +end function get_diag_field_from_id + +!> @brief get the diag_fields of a diag_yaml type +!! @return the diag_fields +pure function get_diag_fields(this) & +result(diag_fields) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + type(diagYamlFilesVar_type), allocatable, dimension (:) :: diag_fields !< Diag fields info + + diag_fields = this%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(diag_subset_output) + integer, intent(in) :: diag_subset_output !< DIAG_ALL - Current PE is in the one and only pelist + !! DIAG_OTHER - Current PE is not in the ocean pelist + !! and there are multiple pelists + !! DIAG_OCEAN - Current PE is in the ocean pelist + !! and there are multiple pelists + 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 :: file_var_count !< The current number of variables added in the diag_file + integer :: nvars !< The number of variables in the current file + integer, allocatable :: var_ids(:) !< Ids of the variables in diag_table yaml + logical :: is_ocean !< Flag indicating if it is an ocean file + logical, allocatable :: ignore(:) !< Flag indicating if the diag_file is going to be ignored + integer :: actual_num_files !< The actual number of files that were saved + integer :: file_count !! The current number of files added to the diag_yaml obj + logical :: write_file !< Flag indicating if the user wants the file to be written + logical :: write_var !< Flag indicating if the user wants the variable to be written + + if (diag_yaml_module_initialized) return + + diag_yaml_id = open_and_parse_file("diag_table.yaml") + + call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title) + call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate) + call set_base_time(diag_yaml%diag_basedate) + + nfiles = get_num_blocks(diag_yaml_id, "diag_files") + allocate(diag_file_ids(nfiles)) + allocate(ignore(nfiles)) + + call get_block_ids(diag_yaml_id, "diag_files", diag_file_ids) + + ignore = .false. + total_nvars = 0 + !< If you are on two seperate pelists + if(diag_subset_output .ne. DIAG_ALL) then + do i = 1, nfiles + is_ocean = .false. + call get_value_from_key(diag_yaml_id, diag_file_ids(i), "is_ocean", is_ocean, is_optional=.true.) + !< If you are on the ocean pelist and the file is not an ocean file, skip the file + if (diag_subset_output .eq. DIAG_OCEAN .and. .not. is_ocean) ignore(i) = .true. + + !< If you are not on the ocean pelist and the file is ocean, skip the file + if(diag_subset_output .eq. DIAG_OTHER .and. is_ocean) ignore(i) = .true. + enddo + endif + + !< Determine how many files are in the diag_yaml, ignoring those with write_file = False + actual_num_files = 0 + do i = 1, nfiles + write_file = .true. + call get_value_from_key(diag_yaml_id, diag_file_ids(i), "write_file", write_file, is_optional=.true.) + if(.not. write_file) ignore(i) = .true. + + if (.not. ignore(i)) then + actual_num_files = actual_num_files + 1 + !< If ignoring the file, ignore the fields in that file too! + total_nvars = total_nvars + get_total_num_vars(diag_yaml_id, diag_file_ids(i)) + endif + enddo + + allocate(diag_yaml%diag_files(actual_num_files)) + allocate(diag_yaml%diag_fields(total_nvars)) + allocate(variable_list%var_name(total_nvars)) + allocate(variable_list%diag_field_indices(total_nvars)) + allocate(file_list%file_name(actual_num_files)) + allocate(file_list%diag_file_indices(actual_num_files)) + + var_count = 0 + file_count = 0 + !> Loop through the number of nfiles and fill in the diag_yaml obj + nfiles_loop: do i = 1, nfiles + if(ignore(i)) cycle + file_count = file_count + 1 + call diag_yaml_files_obj_init(diag_yaml%diag_files(file_count)) + call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(file_count)) + + !> Save the file name in the file_list + !! The diag_table is not case sensitive (so we are saving it as lowercase) + file_list%file_name(file_count) = lowercase(trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char) + file_list%diag_file_indices(file_count) = file_count + + 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)) + file_var_count = 0 + allocate(diag_yaml%diag_files(file_count)%file_varlist(get_total_num_vars(diag_yaml_id, diag_file_ids(i)))) + nvars_loop: do j = 1, nvars + write_var = .true. + call get_value_from_key(diag_yaml_id, var_ids(j), "write_var", write_var, is_optional=.true.) + if (.not. write_var) cycle + + var_count = var_count + 1 + file_var_count = file_var_count + 1 + + !> Save the filename in the diag_field type + diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(file_count)%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(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname + + !> Save the variable name and the module name in the variable_list + variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//& + ":"//trim(diag_yaml%diag_fields(var_count)%var_module)//c_null_char + !! The diag_table is not case sensitive (so we are saving it as lowercase) + variable_list%var_name(var_count) = lowercase(variable_list%var_name(var_count)) + variable_list%diag_field_indices(var_count) = var_count + enddo nvars_loop + deallocate(var_ids) + enddo nfiles_loop + + !> Sort the file list in alphabetical order + file_list%file_pointer = fms_array_to_pointer(file_list%file_name) + call fms_sort_this(file_list%file_pointer, actual_num_files, file_list%diag_file_indices) + + variable_list%var_pointer = fms_array_to_pointer(variable_list%var_name) + call fms_sort_this(variable_list%var_pointer, total_nvars, variable_list%diag_field_indices) + + deallocate(diag_file_ids) + diag_yaml_module_initialized = .true. +end subroutine + +!> @brief Destroys the diag_yaml object +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%corners)) & + deallocate(diag_yaml%diag_files(i)%file_sub_region%corners) + 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) + + if(allocated(file_list%file_pointer)) deallocate(file_list%file_pointer) + if(allocated(file_list%file_name)) deallocate(file_list%file_name) + if(allocated(file_list%diag_file_indices)) deallocate(file_list%diag_file_indices) + + if(allocated(variable_list%var_pointer)) deallocate(variable_list%var_pointer) + if(allocated(variable_list%var_name)) deallocate(variable_list%var_name) + if(allocated(variable_list%diag_field_indices)) deallocate(variable_list%diag_field_indices) + +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, yaml_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) :: yaml_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 + character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml + character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", yaml_fileobj%file_fname) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", buffer) + call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_freq, yaml_fileobj%file_frequnit, "freq") + deallocate(buffer) + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", yaml_fileobj%file_unlimdim) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", buffer) + call set_file_time_units(yaml_fileobj, buffer) + deallocate(buffer) + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", buffer, is_optional=.true.) + call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_new_file_freq, & + yaml_fileobj%file_new_file_freq_units, "new_file_freq") + deallocate(buffer) + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "filename_time", buffer, is_optional=.true.) + call set_filename_time(yaml_fileobj, buffer) + deallocate(buffer) + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", & + yaml_fileobj%file_start_time, is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", buffer, is_optional=.true.) + call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_duration, yaml_fileobj%file_duration_units, & + "file_duration") + + 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", grid_type) + call get_sub_region(diag_yaml_id, sub_region_id(1), yaml_fileobj%file_sub_region, grid_type, & + yaml_fileobj%file_fname) + elseif (nsubregion .eq. 0) then + yaml_fileobj%file_sub_region%grid_type = null_gridtype + else + call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(yaml_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(yaml_fileobj%file_global_meta(nkeys, 2)) + do j = 1, nkeys + call get_key_name(diag_yaml_id, key_ids(j), yaml_fileobj%file_global_meta(j, 1)) + call get_key_value(diag_yaml_id, key_ids(j), yaml_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(yaml_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(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 + 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 + character(len=:), ALLOCATABLE :: buffer !< buffer to store the reduction method as it is read from the yaml + + 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", buffer) + call set_field_reduction(field, buffer) + + call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) + deallocate(buffer) + call diag_get_value_from_key(diag_file_id, var_id, "kind", buffer) + call set_field_kind(field, buffer) + + call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname, is_optional=.true.) + 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 + + !> Set the zbounds if they exist + field%var_zbounds = DIAG_NULL + call get_value_from_key(diag_file_id, var_id, "zbounds", field%var_zbounds, is_optional=.true.) +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, grid_type, fname) + 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 + type(subRegion_type),intent(inout) :: sub_region !< Type that stores the sub_region + character(len=*), intent(in) :: grid_type !< The grid_type as it is read from the file + character(len=*), intent(in) :: fname !< filename of the subregion (for error messages) + + select case (trim(grid_type)) + case ("latlon") + sub_region%grid_type = latlon_gridtype + allocate(real(kind=r4_kind) :: sub_region%corners(4,2)) + case ("index") + sub_region%grid_type = index_gridtype + allocate(integer(kind=i4_kind) :: sub_region%corners(4,2)) + + call get_value_from_key(diag_yaml_id, sub_region_id, "tile", sub_region%tile, is_optional=.true.) + if (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(fname)) + case default + call mpp_error(FATAL, trim(grid_type)//" is not a valid region type. & + &The acceptable values are latlon and index. & + &Check your entry for file:"//trim(fname)) + end select + + call get_value_from_key(diag_yaml_id, sub_region_id, "corner1", sub_region%corners(1,:)) + call get_value_from_key(diag_yaml_id, sub_region_id, "corner2", sub_region%corners(2,:)) + call get_value_from_key(diag_yaml_id, sub_region_id, "corner3", sub_region%corners(3,:)) + call get_value_from_key(diag_yaml_id, sub_region_id, "corner4", sub_region%corners(4,:)) + +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_id) & +result(total_nvars) + + integer, intent(in) :: diag_yaml_id !< Id for the diag_table yaml + integer, intent(in) :: diag_file_id !< Id of the file in the diag_table yaml + integer :: total_nvars + + integer :: i !< For do loop + integer :: nvars !< Number of variables in a file + integer, allocatable :: var_ids(:) !< Id of the variables in the file block of the yaml file + logical :: var_write !< Flag indicating if the user wants the variable to be written + + nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_id) + allocate(var_ids(nvars)) + call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_id) + + !< Loop through all the variables in the diag_file block and only count those that don't have write_var=false + total_nvars = 0 + do i = 1, nvars + var_write = .true. + call get_value_from_key(diag_yaml_id, var_ids(i), "write_var", var_write, is_optional=.true.) + if (var_write) total_nvars = total_nvars + 1 + end do +end function + +!> @brief This parses the freq, new_file_freq, or file_duration keys which are read in as a comma list +subroutine parse_key(filename, buffer, file_freq, file_frequnit, var) + character(len=*), intent(in) :: filename !< The name of the file (for error messages) + character(len=*), intent(inout) :: buffer !< Buffer that was read in from the yaml + integer, intent(out) :: file_freq(:) !< buffer to store the freq, new_file_freq, or + !! file_duration after it is parsed + integer, intent(out) :: file_frequnit(:) !< buffer to store the freq units, new_file_freq units, + !! or file_duration units after it is parsed + character(len=*), intent(in) :: var !< Name of the key parsing + + integer :: j !< location of the ",' in the buffer + integer :: k !< location of the " " that seperated the units + logical :: finished !< .true. if the parsing is complete + integer :: count !< Number of keys that have been parsed + character(len=255) :: str !< Member of the comma seperated list + character(len=10) :: units !< String to hold the units + integer :: err_unit !< Error key + + if (buffer .eq. "") return + + finished = .false. + j = 0 + count = 0 + do while (.not. finished) + count = count + 1 + buffer = buffer(j+1:len_trim(buffer)) + j = index(buffer, ",") + if (j == 0) then + !< There is only 1 member in the list + j = len_trim(buffer)+1 + finished = .true. + endif + + str = adjustl(buffer(1:j-1)) + + k = index(str, " ") + read(str(1:k-1), *, iostat=err_unit) file_freq(count) + units = str(k+1:len_trim(str)) + + if (err_unit .ne. 0) & + call mpp_error(FATAL, "Error parsing "//trim(var)//". Check your entry for file"//& + trim(filename)) + + if (file_freq(count) .lt. -1) & + call mpp_error(FATAL, trim(var)//" is not valid. & + &Check your entry for file:"//trim(filename)) + + if (file_freq(count) .eq. -1 .or. file_freq(count) .eq. 0) then + !! The file is static so no need to read the units + file_frequnit(count) = DIAG_DAYS + else + if (trim(units) .eq. "") & + call mpp_error(FATAL, trim(var)//" units is required. & + &Check your entry for file:"//trim(filename)) + + file_frequnit(count) = set_valid_time_units(units, & + trim(var)//" for file:"//trim(filename)) + endif + enddo +end subroutine parse_key + +!> @brief This checks if the time unit in a diag file is valid and sets the integer equivalent +subroutine set_file_time_units (yaml_fileobj, file_timeunit) + type(diagYamlFiles_type), intent(inout) :: yaml_fileobj !< diagYamlFiles_type obj to checK + character(len=*), intent(in) :: file_timeunit !< file_timeunit as it is read from the diag_table + + yaml_fileobj%file_timeunit = set_valid_time_units(file_timeunit, "timeunit for file:"//trim(yaml_fileobj%file_fname)) +end subroutine set_file_time_units + +!> @brief This checks if the filename_time in a diag file is correct and sets the integer equivalent +subroutine set_filename_time(yaml_fileobj, filename_time) + type(diagYamlFiles_type), intent(inout) :: yaml_fileobj !< diagYamlFiles_type obj to check + character(len=*), intent(in) :: filename_time !< filename_time as it is read from the yaml + + select case (trim(filename_time)) + case ("") + yaml_fileobj%filename_time = middle_time !< This is the default + case ("begin") + yaml_fileobj%filename_time = begin_time + case ("middle") + yaml_fileobj%filename_time = middle_time + case ("end") + yaml_fileobj%filename_time = end_time + case default + call mpp_error(FATAL, trim(filename_time)//" is an invalid filename_time & + &The acceptable values are begin, middle, and end. & + &Check your entry for file "//trim(yaml_fileobj%file_fname)) + end select +end subroutine set_filename_time + +!> @brief This checks if the kind of a diag field is valid and sets it +subroutine set_field_kind(field, skind) + type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into + character(len=*), intent(in) :: skind !< The variable kind as read from diag_yaml + + select case (TRIM(skind)) + case ("r4") + field%var_kind = r4 + case ("r8") + field%var_kind = r8 + case ("i4") + field%var_kind = i4 + case ("i8") + field%var_kind = i8 + case default + call mpp_error(FATAL, trim(skind)//" is an invalid kind! & + &The acceptable values are r4, r8, i4, i8. & + &Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) + end select + +end subroutine set_field_kind + +!> @brief This checks if the reduction of a diag field is valid and sets it +!! If the reduction method is diurnalXX or powXX, it gets the number of diurnal sample and the power value +subroutine set_field_reduction(field, reduction_method) + type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into + character(len=*) , intent(in) :: reduction_method!< reduction method as read from the yaml + + 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 (index(reduction_method, "diurnal") .ne. 0) then + READ (UNIT=reduction_method(8:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) n_diurnal + if (ioerror .ne. 0) & + call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(reduction_method)) + 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)) + field%var_reduction = time_diurnal + elseif (index(reduction_method, "pow") .ne. 0) then + READ (UNIT=reduction_method(4:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) pow_value + if (ioerror .ne. 0) & + call mpp_error(FATAL, "Error getting the power value from "//trim(reduction_method)) + 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)) + field%var_reduction = time_power + else + select case (reduction_method) + case ("none") + field%var_reduction = time_none + case ("average") + field%var_reduction = time_average + case ("min") + field%var_reduction = time_min + case ("max") + field%var_reduction = time_max + case ("rms") + field%var_reduction = time_rms + case ("sum") + field%var_reduction = time_sum + case default + call mpp_error(FATAL, trim(reduction_method)//" 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 + + field%n_diurnal = n_diurnal + field%pow_value = pow_value +end subroutine set_field_reduction + +!> @brief This checks if a time unit is valid and if it is, it assigns the integer equivalent +!! @return The integer equivalent to the time units +function set_valid_time_units(time_units, error_msg) & +result(time_units_int) + + character(len=*), intent(in) :: time_units !< The time_units as a string + character(len=*), intent(in) :: error_msg !< Error message to append + + integer :: time_units_int !< The integer equivalent of the time_units + + select case (TRIM(time_units)) + case ("seconds") + time_units_int = DIAG_SECONDS + case ("minutes") + time_units_int = DIAG_MINUTES + case ("hours") + time_units_int = DIAG_HOURS + case ("days") + time_units_int = DIAG_DAYS + case ("months") + time_units_int = DIAG_MONTHS + case ("years") + time_units_int = DIAG_YEARS + case default + time_units_int =DIAG_NULL + call mpp_error(FATAL, trim(error_msg)//" is not valid. Acceptable values are "& + "seconds, minutes, hours, days, months, years") + end select +end function set_valid_time_units + +!!!!!!! YAML FILE INQUIRIES !!!!!!! +!> @brief Finds the number of variables in the file_varlist +!! @return the size of the diag_files_obj%file_varlist array +integer pure function size_file_varlist (this) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + size_file_varlist = size(this%file_varlist) +end function size_file_varlist + +!> @brief Inquiry for diag_files_obj%file_fname +!! @return file_fname of a diag_yaml_file obj +pure function get_file_fname (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_frequnit(this%current_new_file_freq_index) +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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_freq(this%current_new_file_freq_index) +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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%file_unlimdim +end function get_file_unlimdim +!> @brief Inquiry for diag_files_obj%file_subregion +!! @return file_sub_region of a diag_yaml_file_obj +function get_file_sub_region (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + type(subRegion_type) :: res !< What is returned + res = this%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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_new_file_freq(this%current_new_file_freq_index) +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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_new_file_freq_units(this%current_new_file_freq_index) +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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_duration(this%current_new_file_freq_index) +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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%file_duration_units(this%current_new_file_freq_index) +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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (:), allocatable :: res(:) !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=MAX_STR_LEN), allocatable :: res(:,:) !< What is returned + res = this%file_global_meta +end function get_file_global_meta +!> @brief Get the integer equivalent of the time to use to determine the filename, +!! if using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr) +!! @return the integer equivalent of the time to use to determine the filename +pure function get_filename_time(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%filename_time +end function +!> @brief Inquiry for whether file_global_meta is allocated +!! @return Flag indicating if file_global_meta is allocated +function is_global_meta(this) & + result(res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + logical :: res + res = .false. + if (allocated(this%file_global_meta)) & + res = .true. +end function + +!> @brief Increate the current_new_file_freq_index by 1 +subroutine increase_new_file_freq_index(this) + class(diagYamlFiles_type), intent(inout) :: this !< The file object + this%current_new_file_freq_index = this%current_new_file_freq_index + 1 +end subroutine +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer, allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%var_module +end function get_var_module +!> @brief Inquiry for diag_yaml_files_var_obj%var_kind +!! @return var_kind of a diag_yaml_files_var_obj +pure function get_var_kind (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer, allocatable :: res !< What is returned + res = this%var_kind +end function get_var_kind +!> @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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + + if (this%has_var_outname()) then + res = this%var_outname + else + res = this%var_varname !< If outname is not set, the variable name will be used + endif +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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = this%var_units +end function get_var_units +!> @brief Inquiry for diag_yaml_files_var_obj%var_zbounds +!! @return var_zbounds of a diag_yaml_files_var_obj +pure function get_var_zbounds (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + real(kind=r4_kind) :: res(2) !< What is returned + res = this%var_zbounds +end function get_var_zbounds +!> @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(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned + res = this%var_attributes +end function get_var_attributes +!> @brief Inquiry for diag_yaml_files_var_obj%n_diurnal +!! @return the number of diurnal samples of a diag_yaml_files_var_obj +pure function get_n_diurnal(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%n_diurnal +end function get_n_diurnal +!> @brief Inquiry for diag_yaml_files_var_obj%pow_value +!! @return the pow_value of a diag_yaml_files_var_obj +pure function get_pow_value(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + res = this%pow_value +end function get_pow_value +!> @brief Inquiry for whether var_attributes is allocated +!! @return Flag indicating if var_attributes is allocated +function is_var_attributes(this) & +result(res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + logical :: res + res = .false. + if (allocated(this%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_sub_region%tile = DIAG_NULL + obj%file_new_file_freq = DIAG_NULL + obj%file_duration = DIAG_NULL + obj%file_new_file_freq_units = DIAG_NULL + obj%file_duration_units = DIAG_NULL + obj%current_new_file_freq_index = 1 +end subroutine diag_yaml_files_obj_init + +!> @brief Checks if diag_file_obj%file_fname is allocated +!! @return true if diag_file_obj%file_fname is allocated +pure logical function has_file_fname (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_fname = allocated(this%file_fname) +end function has_file_fname +!> @brief Checks if diag_file_obj%file_frequnit is allocated +!! @return true if diag_file_obj%file_frequnit is allocated +pure logical function has_file_frequnit (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_frequnit = this%file_frequnit(this%current_new_file_freq_index) .NE. DIAG_NULL +end function has_file_frequnit +!> @brief diag_file_obj%file_freq is on the stack, so the object always has it +!! @return true if diag_file_obj%file_freq is allocated +pure logical function has_file_freq (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_freq = .true. +end function has_file_freq +!> @brief Checks if diag_file_obj%file_timeunit is allocated +!! @return true if diag_file_obj%file_timeunit is allocated +pure logical function has_file_timeunit (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_timeunit = this%file_timeunit .ne. diag_null +end function has_file_timeunit +!> @brief Checks if diag_file_obj%file_unlimdim is allocated +!! @return true if diag_file_obj%file_unlimdim is allocated +pure logical function has_file_unlimdim (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_unlimdim = allocated(this%file_unlimdim) +end function has_file_unlimdim +!> @brief Checks if diag_file_obj%file_write is on the stack, so this will always be true +!! @return true +pure logical function has_file_write (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_write = .true. +end function has_file_write +!> @brief Checks if diag_file_obj%file_sub_region is being used and has the sub region variables allocated +!! @return true if diag_file_obj%file_sub_region sub region variables are allocated +pure logical function has_file_sub_region (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + if ( this%file_sub_region%grid_type .eq. latlon_gridtype .or. this%file_sub_region%grid_type .eq. index_gridtype) then + has_file_sub_region = .true. + else + has_file_sub_region = .false. + endif +end function has_file_sub_region +!> @brief diag_file_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 (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_new_file_freq = this%file_new_file_freq(this%current_new_file_freq_index) .ne. DIAG_NULL +end function has_file_new_file_freq +!> @brief Checks if diag_file_obj%file_new_file_freq_units is allocated +!! @return true if diag_file_obj%file_new_file_freq_units is allocated +pure logical function has_file_new_file_freq_units (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_new_file_freq_units = this%file_new_file_freq_units(this%current_new_file_freq_index) .ne. diag_null +end function has_file_new_file_freq_units +!> @brief Checks if diag_file_obj%file_start_time is allocated +!! @return true if diag_file_obj%file_start_time is allocated +pure logical function has_file_start_time (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_start_time = allocated(this%file_start_time) +end function has_file_start_time +!> @brief diag_file_obj%file_duration is allocated on th stack, so this is always true +!! @return true +pure logical function has_file_duration (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_duration = this%file_duration(this%current_new_file_freq_index) .ne. DIAG_NULL +end function has_file_duration +!> @brief diag_file_obj%file_duration_units is on the stack, so this will retrun true +!! @return true +pure logical function has_file_duration_units (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_duration_units = this%file_duration_units(this%current_new_file_freq_index) .ne. diag_null +end function has_file_duration_units +!> @brief Checks if diag_file_obj%file_varlist is allocated +!! @return true if diag_file_obj%file_varlist is allocated +pure logical function has_file_varlist (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_varlist = allocated(this%file_varlist) +end function has_file_varlist +!> @brief Checks if diag_file_obj%file_global_meta is allocated +!! @return true if diag_file_obj%file_global_meta is allocated +pure logical function has_file_global_meta (this) + class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize + has_file_global_meta = allocated(this%file_global_meta) +end function has_file_global_meta + +!> @brief Checks if diag_file_obj%var_fname is allocated +!! @return true if diag_file_obj%var_fname is allocated +pure logical function has_var_fname (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_fname = allocated(this%var_fname) +end function has_var_fname +!> @brief Checks if diag_file_obj%var_varname is allocated +!! @return true if diag_file_obj%var_varname is allocated +pure logical function has_var_varname (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_varname = allocated(this%var_varname) +end function has_var_varname +!> @brief Checks if diag_file_obj%var_reduction is allocated +!! @return true if diag_file_obj%var_reduction is allocated +pure logical function has_var_reduction (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_reduction = allocated(this%var_reduction) +end function has_var_reduction +!> @brief Checks if diag_file_obj%var_module is allocated +!! @return true if diag_file_obj%var_module is allocated +pure logical function has_var_module (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_module = allocated(this%var_module) +end function has_var_module +!> @brief Checks if diag_file_obj%var_kind is allocated +!! @return true if diag_file_obj%var_kind is allocated +pure logical function has_var_kind (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_kind = allocated(this%var_kind) +end function has_var_kind +!> @brief diag_file_obj%var_write is on the stack, so this returns true +!! @return true +pure logical function has_var_write (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_write = .true. +end function has_var_write +!> @brief Checks if diag_file_obj%var_outname is allocated +!! @return true if diag_file_obj%var_outname is allocated +pure logical function has_var_outname (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + if (allocated(this%var_outname)) then + if (trim(this%var_outname) .ne. "") then + has_var_outname = .true. + else + has_var_outname = .false. + endif + else + has_var_outname = .true. + endif +end function has_var_outname +!> @brief Checks if diag_file_obj%var_longname is allocated +!! @return true if diag_file_obj%var_longname is allocated +pure logical function has_var_longname (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_longname = allocated(this%var_longname) +end function has_var_longname +!> @brief Checks if diag_file_obj%var_units is allocated +!! @return true if diag_file_obj%var_units is allocated +pure logical function has_var_units (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_units = allocated(this%var_units) +end function has_var_units +!> @brief Checks if diag_file_obj%var_zbounds is allocated +!! @return true if diag_file_obj%var_zbounds is allocated +pure logical function has_var_zbounds (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_zbounds = any(this%var_zbounds .ne. diag_null) +end function has_var_zbounds +!> @brief Checks if diag_file_obj%var_attributes is allocated +!! @return true if diag_file_obj%var_attributes is allocated +pure logical function has_var_attributes (this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize + has_var_attributes = allocated(this%var_attributes) +end function has_var_attributes +!> @brief Checks if diag_file_obj%n_diurnal is set +!! @return true if diag_file_obj%n_diurnal is set +pure logical function has_n_diurnal(this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to inquire + has_n_diurnal = (this%n_diurnal .ne. 0) +end function has_n_diurnal +!> @brief Checks if diag_file_obj%pow_value is set +!! @return true if diag_file_obj%pow_value is set +pure logical function has_pow_value(this) + class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to inquire + has_pow_value = (this%pow_value .ne. 0) +end function has_pow_value + +!> @brief Checks if diag_file_obj%diag_title is allocated +!! @return true if diag_file_obj%diag_title is allocated +pure logical function has_diag_title (this) + class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to inquire + has_diag_title = allocated(this%diag_title) +end function has_diag_title +!> @brief diag_file_obj%diag_basedate is on the stack, so this is always true +!! @return true +pure logical function has_diag_basedate (this) + class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize + has_diag_basedate = .true. +end function has_diag_basedate +!> @brief Checks if diag_file_obj%diag_files is allocated +!! @return true if diag_file_obj%diag_files is allocated +pure logical function has_diag_files (this) + class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize + has_diag_files = allocated(this%diag_files) +end function has_diag_files +!> @brief Checks if diag_file_obj%diag_fields is allocated +!! @return true if diag_file_obj%diag_fields is allocated +pure logical function has_diag_fields (this) + class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize + has_diag_fields = allocated(this%diag_fields) +end function has_diag_fields + +!> @brief Determine the number of unique diag_fields in the diag_yaml_object +!! @return The number of unique diag_fields +function get_num_unique_fields() & + result(nfields) + integer :: nfields + nfields = fms_find_unique(variable_list%var_pointer, size(variable_list%var_pointer)) + +end function get_num_unique_fields + +!> @brief Determines if a diag_field is in the diag_yaml_object +!! @return Indices of the locations where the field was found +function find_diag_field(diag_field_name, module_name) & +result(indices) + + character(len=*), intent(in) :: diag_field_name !< diag_field name to search for + character(len=*), intent(in) :: module_name !< Name of the module, the variable is in + + integer, allocatable :: indices(:) + + indices = fms_find_my_string(variable_list%var_pointer, size(variable_list%var_pointer), & + & lowercase(trim(diag_field_name))//":"//lowercase(trim(module_name)//c_null_char)) +end function find_diag_field + +!> @brief Gets the diag_field entries corresponding to the indices of the sorted variable_list +!! @return Array of diag_fields +function get_diag_fields_entries(indices) & + result(diag_field) + + integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list array + type(diagYamlFilesVar_type), dimension (:), allocatable :: diag_field + + integer :: i !< For do loops + integer :: field_id !< Indices of the field in the diag_yaml array + + allocate(diag_field(size(indices))) + + do i = 1, size(indices) + field_id = variable_list%diag_field_indices(indices(i)) + diag_field(i) = diag_yaml%diag_fields(field_id) + end do + +end function get_diag_fields_entries + +!> @brief Gets field indices corresponding to the indices (input argument) in the sorted variable_list +!! @return Copy of array of field indices +function get_diag_field_ids(indices) result(field_ids) + + integer, intent(in) :: indices(:) !< Indices of the fields in the sorted variable_list array + integer, allocatable :: field_ids(:) + integer :: i !< For do loop + + allocate(field_ids(size(indices))) + + do i = 1, size(indices) + field_ids(i) = variable_list%diag_field_indices(indices(i)) + end do + +end function get_diag_field_ids + +!> @brief Finds the indices of the diag_yaml%diag_files(:) corresponding to fields in variable_list(indices) +!! @return indices of the diag_yaml%diag_files(:) +function get_diag_files_id(indices) & + result(file_id) + + integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list + integer, allocatable :: file_id(:) + + integer :: field_id !< Indices of the field in the diag_yaml field array + integer :: i !< For do loops + character(len=120) :: filename !< Filename of the field + integer, allocatable :: file_indices(:) !< Indices of the file in the sorted variable_list + + allocate(file_id(size(indices))) + + do i = 1, size(indices) + field_id = variable_list%diag_field_indices(indices(i)) + !< Get the filename of the field + filename = diag_yaml%diag_fields(field_id)%var_fname + + !< File indice of that file in the array of list of sorted files + file_indices = fms_find_my_string(file_list%file_pointer, size(file_list%file_pointer), & + & trim(filename)//c_null_char) + + if (size(file_indices) .ne. 1) & + & call mpp_error(FATAL, "get_diag_files_id: Error getting the correct number of file indices!") + + if (file_indices(1) .eq. diag_null) & + & call mpp_error(FATAL, "get_diag_files_id: Error finding the filename in the diag_files yaml") + + !< Get the index of the file in the diag_yaml file + file_id(i) = file_list%diag_file_indices(file_indices(1)) + end do + +end function get_diag_files_id + +!> Prints out values from diag_yaml object for debugging. +!! Only writes on root. +subroutine dump_diag_yaml_obj( filename ) + character(len=*), optional, intent(in) :: filename !< optional name of logfile to write to, otherwise + !! prints to stdout + type(diagyamlfilesvar_type), allocatable :: fields(:) + type(diagyamlfiles_type), allocatable :: files(:) + integer :: i, unit_num + if( present(filename)) then + open(newunit=unit_num, file=trim(filename), action='WRITE') + else + unit_num = stdout() + endif + !! TODO write to log + if( mpp_pe() .eq. mpp_root_pe()) then + write(unit_num, *) '**********Dumping diag_yaml object**********' + if( diag_yaml%has_diag_title()) write(unit_num, *) 'Title:', diag_yaml%diag_title + if( diag_yaml%has_diag_basedate()) write(unit_num, *) 'basedate array:', diag_yaml%diag_basedate + write(unit_num, *) 'FILES' + allocate(fields(SIZE(diag_yaml%get_diag_fields()))) + allocate(files(SIZE(diag_yaml%get_diag_files()))) + files = diag_yaml%get_diag_files() + fields = diag_yaml%get_diag_fields() + do i=1, SIZE(files) + write(unit_num, *) 'File: ', files(i)%get_file_fname() + if(files(i)%has_file_frequnit()) write(unit_num, *) 'file_frequnit:', files(i)%get_file_frequnit() + if(files(i)%has_file_freq()) write(unit_num, *) 'freq:', files(i)%get_file_freq() + if(files(i)%has_file_timeunit()) write(unit_num, *) 'timeunit:', files(i)%get_file_timeunit() + if(files(i)%has_file_unlimdim()) write(unit_num, *) 'unlimdim:', files(i)%get_file_unlimdim() + !if(files(i)%has_file_sub_region()) write(unit_num, *) 'sub_region:', files(i)%get_file_sub_region() + if(files(i)%has_file_new_file_freq()) write(unit_num, *) 'new_file_freq:', files(i)%get_file_new_file_freq() + if(files(i)%has_file_new_file_freq_units()) write(unit_num, *) 'new_file_freq_units:', & + & files(i)%get_file_new_file_freq_units() + if(files(i)%has_file_start_time()) write(unit_num, *) 'start_time:', files(i)%get_file_start_time() + if(files(i)%has_file_duration()) write(unit_num, *) 'duration:', files(i)%get_file_duration() + if(files(i)%has_file_duration_units()) write(unit_num, *) 'duration_units:', files(i)%get_file_duration_units() + if(files(i)%has_file_varlist()) write(unit_num, *) 'varlist:', files(i)%get_file_varlist() + if(files(i)%has_file_global_meta()) write(unit_num, *) 'global_meta:', files(i)%get_file_global_meta() + if(files(i)%is_global_meta()) write(unit_num, *) 'global_meta:', files(i)%is_global_meta() + write(unit_num, *) '' + enddo + write(unit_num, *) 'FIELDS' + do i=1, SIZE(fields) + write(unit_num, *) 'Field: ', fields(i)%get_var_fname() + if(fields(i)%has_var_fname()) write(unit_num, *) 'fname:', fields(i)%get_var_fname() + if(fields(i)%has_var_varname()) write(unit_num, *) 'varname:', fields(i)%get_var_varname() + if(fields(i)%has_var_reduction()) write(unit_num, *) 'reduction:', fields(i)%get_var_reduction() + if(fields(i)%has_var_module()) write(unit_num, *) 'module:', fields(i)%get_var_module() + if(fields(i)%has_var_kind()) write(unit_num, *) 'kind:', fields(i)%get_var_kind() + if(fields(i)%has_var_outname()) write(unit_num, *) 'outname:', fields(i)%get_var_outname() + if(fields(i)%has_var_longname()) write(unit_num, *) 'longname:', fields(i)%get_var_longname() + if(fields(i)%has_var_units()) write(unit_num, *) 'units:', fields(i)%get_var_units() + if(fields(i)%has_var_zbounds()) write(unit_num, *) 'zbounds:', fields(i)%get_var_zbounds() + if(fields(i)%has_var_attributes()) write(unit_num, *) 'attributes:', fields(i)%get_var_attributes() + if(fields(i)%has_n_diurnal()) write(unit_num, *) 'n_diurnal:', fields(i)%get_n_diurnal() + if(fields(i)%has_pow_value()) write(unit_num, *) 'pow_value:', fields(i)%get_pow_value() + if(fields(i)%has_var_attributes()) write(unit_num, *) 'is_var_attributes:', fields(i)%is_var_attributes() + enddo + deallocate(files, fields) + if( present(filename)) then + close(unit_num) + endif + endif +end subroutine + +#endif +end module fms_diag_yaml_mod +!> @} +! close documentation grouping diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc new file mode 100644 index 0000000000..c847817724 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods.inc @@ -0,0 +1,299 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +! for any debug prints +#ifndef DEBUG_REDUCT +#define DEBUG_REDUCT .true. +#endif + +!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data) +subroutine DO_TIME_NONE_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with + logical, intent(in) :: mask(:,:,:,:) !< mask + logical, intent(in) :: is_masked !< .True. if the field is using a mask + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion + !! of the input buffer + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion + !! of the output buffer + real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked + + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for + !! the input buffer + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for + !! the output buffer + + is_out = bounds_out%get_imin() + ie_out = bounds_out%get_imax() + js_out = bounds_out%get_jmin() + je_out = bounds_out%get_jmax() + ks_out = bounds_out%get_kmin() + ke_out = bounds_out%get_kmax() + + is_in = bounds_in%get_imin() + ie_in = bounds_in%get_imax() + js_in = bounds_in%get_jmin() + je_in = bounds_in%get_jmax() + ks_in = bounds_in%get_kmin() + ke_in = bounds_in%get_kmax() + + if (is_masked) then + where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) + data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = & + data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) + elsewhere + data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = missing_value + end where + else + data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = & + data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) + endif + +end subroutine DO_TIME_NONE_ + +!> @brief Do the time_min reduction method (i.e maintain the minimum value of the averaging time) +subroutine DO_TIME_MIN_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with + logical, intent(in) :: mask(:,:,:,:) !< mask + logical, intent(in) :: is_masked !< .True. if the field is using a mask + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion + !! of the input buffer + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion + !! of the output buffer + real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked + + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for + !! the input buffer + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for + !! the output buffer + + integer :: i, j, k, l !< For looping + + is_out = bounds_out%get_imin() + ie_out = bounds_out%get_imax() + js_out = bounds_out%get_jmin() + je_out = bounds_out%get_jmax() + ks_out = bounds_out%get_kmin() + ke_out = bounds_out%get_kmax() + + is_in = bounds_in%get_imin() + ie_in = bounds_in%get_imax() + js_in = bounds_in%get_jmin() + je_in = bounds_in%get_jmax() + ks_in = bounds_in%get_kmin() + ke_in = bounds_in%get_kmax() + + !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in) + !! then mask will always be .True. so the if (mask) is redudant. + if (is_masked) then + do l = 0, size(data_out, 4) - 1 + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + if (mask(is_in + i, js_in + j, ks_in + k, l + 1)) then + if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. & + data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = & + data_in(is_in +i, js_in + j, ks_in + k, l + 1) + endif + else + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value + endif + enddo + enddo + enddo + enddo + else + do l = 0, size(data_out, 4) - 1 + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. & + data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = & + data_in(is_in +i, js_in + j, ks_in + k, l + 1) + endif + enddo + enddo + enddo + enddo + endif + +end subroutine DO_TIME_MIN_ + +!> @brief Do the time_max reduction method (i.e maintain the maximum value of the averaging time) +subroutine DO_TIME_MAX_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with + logical, intent(in) :: mask(:,:,:,:) !< mask + logical, intent(in) :: is_masked !< .True. if the field is using a mask + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion + !! of the input buffer + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion + !! of the output buffer + real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked + + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for + !! the input buffer + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for + !! the output buffer + + integer :: i, j, k, l !< For looping + + is_out = bounds_out%get_imin() + ie_out = bounds_out%get_imax() + js_out = bounds_out%get_jmin() + je_out = bounds_out%get_jmax() + ks_out = bounds_out%get_kmin() + ke_out = bounds_out%get_kmax() + + is_in = bounds_in%get_imin() + ie_in = bounds_in%get_imax() + js_in = bounds_in%get_jmin() + je_in = bounds_in%get_jmax() + ks_in = bounds_in%get_kmin() + ke_in = bounds_in%get_kmax() + + !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in) + !! then mask will always be .True. so the if (mask) is redudant. + if (is_masked) then + do l = 0, size(data_out, 4) - 1 + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + if (mask(is_in + i, js_in + j, ks_in + k, l + 1)) then + if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. & + data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = & + data_in(is_in +i, js_in + j, ks_in + k, l + 1) + endif + else + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value + endif + enddo + enddo + enddo + enddo + else + do l = 0, size(data_out, 4) - 1 + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. & + data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then + data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = & + data_in(is_in +i, js_in + j, ks_in + k, l + 1) + endif + enddo + enddo + enddo + enddo + endif +end subroutine DO_TIME_MAX_ + +!> Update the output buffer for reductions that involve summation (sum, avg, rms, pow). +!! Elements of the running field output buffer (data_out) are set with the following: +!! +!! buffer(l) = buffer(l) + (weight * field(l)) ^ pow +!! +!! Where l are the indices passed in through the bounds_in/out +subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, bounds_in, bounds_out, & + missing_value, weight, pow) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data + real(r8_kind), intent(inout) :: weight_sum !< Sum of weights from the output buffer object + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with + logical, intent(in) :: mask(:,:,:,:) !< mask + logical, intent(in) :: is_masked !< .True. if the field is using a mask + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion + !! of the input buffer + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion + !! of the output buffer + real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked + real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out + !! used for weighted averages, default 1.0 + real(FMS_TRM_KIND_),optional, intent(in) :: pow !< Used for pow reduction, adds field^pow to buffer + + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for + !! the input buffer + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for + !! the output buffer + integer :: i, j, k, l !< For looping + real(FMS_TRM_KIND_) :: weight_loc, pow_loc !< local copies of optional arguments + integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro + + if(present(weight)) then + weight_loc = weight + else + weight_loc = 1.0_kindl + endif + + if(present(pow)) then + pow_loc = weight + else + pow_loc = 1.0_kindl + endif + + ! update with given weight for average before write + weight_sum = weight_sum + weight_loc + + is_out = bounds_out%get_imin() + ie_out = bounds_out%get_imax() + js_out = bounds_out%get_jmin() + je_out = bounds_out%get_jmax() + ks_out = bounds_out%get_kmin() + ke_out = bounds_out%get_kmax() + + is_in = bounds_in%get_imin() + ie_in = bounds_in%get_imax() + js_in = bounds_in%get_jmin() + je_in = bounds_in%get_jmax() + ks_in = bounds_in%get_kmin() + ke_in = bounds_in%get_kmax() + + !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in) + !! then mask will always be .True. so the if (mask) is redudant. + ! TODO check if performance gain by not doing weight and pow if not needed + if (is_masked) then + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + where (mask(is_in + i, js_in + j, ks_in + k, :)) + data_out(is_out + i, js_out + j, ks_out + k, :, 1) = & + data_out(is_out + i, js_out + j, ks_out + k, :, 1) & + + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc + elsewhere + data_out(is_out + i, js_out + j, ks_out + k, :, 1) = missing_value + endwhere + enddo + enddo + enddo + else + ! doesn't need to loop through l if no mask, just sums the 1d slices + do k = 0, ke_out - ks_out + do j = 0, je_out - js_out + do i = 0, ie_out - is_out + data_out(is_out + i, js_out + j, ks_out + k, :, 1) = & + data_out(is_out + i, js_out + j, ks_out + k, :, 1) & + + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc + enddo + enddo + enddo + endif +end subroutine DO_TIME_SUM_UPDATE_ diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh new file mode 100644 index 0000000000..a3c499b12e --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh @@ -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 . +!*********************************************************************** +!> @file +!> @brief Imports the time reduction methods routines from other include files used +!! in @ref diag_manager_mod + +!> @addtogroup diag_manager_mod +!> @{ + +#undef FMS_TRM_KIND_ +#define FMS_TRM_KIND_ r4_kind + +#undef DO_TIME_NONE_ +#define DO_TIME_NONE_ do_time_none_r4 + +#undef DO_TIME_MIN_ +#define DO_TIME_MIN_ do_time_min_r4 + +#undef DO_TIME_MAX_ +#define DO_TIME_MAX_ do_time_max_r4 + +#undef DO_TIME_SUM_UPDATE_ +#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r4 + +#include "fms_diag_reduction_methods.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh new file mode 100644 index 0000000000..d550293113 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh @@ -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 . +!*********************************************************************** +!> @file +!> @brief Imports the time reduction methods routines from other include files used +!! in @ref diag_manager_mod + +!> @addtogroup diag_manager_mod +!> @{ + +#undef FMS_TRM_KIND_ +#define FMS_TRM_KIND_ r8_kind + +#undef DO_TIME_NONE_ +#define DO_TIME_NONE_ do_time_none_r8 + +#undef DO_TIME_MIN_ +#define DO_TIME_MIN_ do_time_min_r8 + +#undef DO_TIME_MAX_ +#define DO_TIME_MAX_ do_time_max_r8 + +#undef DO_TIME_SUM_UPDATE_ +#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r8 + +#include "fms_diag_reduction_methods.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index a00cf6b7c0..5ea77e4ce7 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -711,6 +711,13 @@ subroutine interpolator_end(clim_type) deallocate(clim_type%r8_type%nmon_pyear) end if endif +if (allocated(clim_type%indexm)) deallocate(clim_type%indexm) +if (allocated(clim_type%indexp)) deallocate(clim_type%indexp) +if (allocated(clim_type%climatology)) deallocate(clim_type%climatology) +if (allocated(clim_type%clim_times)) deallocate(clim_type%clim_times) + +clim_type%r4_type%is_allocated=.false. +clim_type%r8_type%is_allocated=.false. clim_type%r4_type%is_allocated=.false. clim_type%r8_type%is_allocated=.false. diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index d71512a364..6c892691ff 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -58,10 +58,10 @@ test_data_override_ongrid_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind test_get_grid_v1_r4_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r4_kind test_get_grid_v1_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind -if SKIP_PARSER_TESTS -skipflag="skip" -else +if USING_YAML skipflag="" +else +skipflag="skip" endif TEST_EXTENSIONS = .sh diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index f5e646cd27..35c0aa3198 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -28,21 +28,47 @@ AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$( LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_update_buffer +check_PROGRAMS = test_diag_manager test_diag_manager_time \ + test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \ + test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \ + check_time_min check_time_max check_time_sum # 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_update_buffer_SOURCES= test_diag_update_buffer.F90 +test_diag_yaml_SOURCES = test_diag_yaml.F90 +test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90 +test_diag_ocean_SOURCES = test_diag_ocean.F90 +test_modern_diag_SOURCES = test_modern_diag.F90 +test_diag_buffer_SOURCES= test_diag_buffer.F90 +test_flexible_time_SOURCES = test_flexible_time.F90 +test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90 +check_time_none_SOURCES = testing_utils.F90 check_time_none.F90 +check_time_min_SOURCES = testing_utils.F90 check_time_min.F90 +check_time_max_SOURCES = testing_utils.F90 check_time_max.F90 +check_time_sum_SOURCES = testing_utils.F90 check_time_sum.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh # Run the test. -TESTS = test_diag_manager2.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh + +testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \ + test_time_sum.sh + +if USING_YAML +skipflag="" +else +skipflag="skip" +endif + +TESTS_ENVIRONMENT = skipflag=${skipflag} + +CLEANFILES = *.yaml input.nml *.nc *.out diag_table* *-files/* *.dpi *.spi *.dyn *.spl *.mod -CLEANFILES = input.nml *.nc *.out diag_table *-files/* *.dpi *.spi *.dyn *.spl diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh new file mode 100755 index 0000000000..0a9a7cfeca --- /dev/null +++ b/test_fms/diag_manager/check_crashes.sh @@ -0,0 +1,96 @@ +#!/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. + +printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml +sed '/tile/d' diag_table.yaml_base > diag_table.yaml +test_expect_failure "Missing tile when using the 'index' grid type" ' + mpirun -n 1 ../test_diag_yaml +' + +sed '/new_file_freq: 6 hours/new_file_freq: 6/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "Missing new_file_freq_units when using new_file_freq_units" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/new_file_freq: 6 hours/new_file_freq: 6 mullions/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "new_file_freq_units is not valid" ' + mpirun -n 1 ../test_diag_yaml +' + +sed '/file_duration: 12 hours/file_duration: 12/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "Missing file_duration_units when using file_duration" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/file_duration: 12 hours/file_duration: 12 mullions/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "file_duration_units is not valid" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/freq: 6 hours/freq: 6 mullions/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "freq units is not valid" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/freq: 6 hours/freq: -6 hours/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "freq is less than -1" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/kind: r4/kind: mullions/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "kind is not valid" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/reduction: average/reduction: mullions/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "reduction is not valid" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/reduction: average/reduction: diurnal0/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "diurnal samples is less than 0" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/reduction: average/reduction: diurnal99r/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "diurnal samples is not an integer" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/reduction: average/reduction: pow0/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "power value is less than 0" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/reduction: average/reduction: pow99r/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "power value is not an integer" ' + mpirun -n 1 ../test_diag_yaml +' + +sed 's/grid_type: latlon/grid_type: ice_cream/g' diag_table.yaml_base > diag_table.yaml +test_expect_failure "the sub_region grid_type is not valid" ' + mpirun -n 1 ../test_diag_yaml +' diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90 new file mode 100644 index 0000000000..fd835ce4a3 --- /dev/null +++ b/test_fms/diag_manager/check_time_max.F90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "max" reduction method +program check_time_max + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + implicit none + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_max.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_max_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_max_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open file") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_max - time_level:", string(i) + call read_data(fileobj, "var0_max", cdata_out(1,1,1,1), unlim_dim_level=i) + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_max - time_level:", string(i) + call read_data(fileobj, "var1_max", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_max - time_level:", string(i) + call read_data(fileobj, "var2_max", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max - time_level:", string(i) + call read_data(fileobj, "var3_max", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var4_max - time_level:", string(i) + call read_data(fileobj, "var4_max", cdata_out(:,:,:,:), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + call check_data_3d(cdata_out(:,:,:,2), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z_max - time_level:", string(i) + call read_data(fileobj, "var3_Z_max", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_max", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_max", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer, buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program \ No newline at end of file diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90 new file mode 100644 index 0000000000..da2440a638 --- /dev/null +++ b/test_fms/diag_manager/check_time_min.F90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "min" reduction method +program check_time_min + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + implicit none + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_min.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_min_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_min_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open file") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_min - time_level:", string(i) + call read_data(fileobj, "var0_min", cdata_out(1,1,1,1), unlim_dim_level=i) + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_min - time_level:", string(i) + call read_data(fileobj, "var1_min", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_min - time_level:", string(i) + call read_data(fileobj, "var2_min", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min - time_level:", string(i) + call read_data(fileobj, "var3_min", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var4_min - time_level:", string(i) + call read_data(fileobj, "var4_min", cdata_out(:,:,:,:), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + call check_data_3d(cdata_out(:,:,:,2), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z_min - time_level:", string(i) + call read_data(fileobj, "var3_Z_min", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_min", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_min", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer, buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program \ No newline at end of file diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 new file mode 100644 index 0000000000..e0b3f73541 --- /dev/null +++ b/test_fms/diag_manager/check_time_none.F90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "none" reduction method +program check_time_none + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + implicit none + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_none.nc", "read")) & + call mpp_error(FATAL, "unable to open test_none.nc") + + if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open test_none_regional.nc.0004") + + if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open test_none_regional.nc.0005") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_none - time_level:", string(i) + call read_data(fileobj, "var0_none", cdata_out(1,1,1,1), unlim_dim_level=i) + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_none - time_level:", string(i) + call read_data(fileobj, "var1_none", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_none - time_level:", string(i) + call read_data(fileobj, "var2_none", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none - time_level:", string(i) + call read_data(fileobj, "var3_none", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var4_none - time_level:", string(i) + call read_data(fileobj, "var4_none", cdata_out(:,:,:,:), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + call check_data_3d(cdata_out(:,:,:,2), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z - time_level:", string(i) + call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_none", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_none", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer_exp, buffer + call mpp_error(FATAL, "Check_time_none::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program diff --git a/test_fms/diag_manager/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90 new file mode 100644 index 0000000000..463e1cea5f --- /dev/null +++ b/test_fms/diag_manager/check_time_sum.F90 @@ -0,0 +1,270 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "time_sum" reduction method +program check_time_sum + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + implicit none + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: ti !< For looping through time levels + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + integer, parameter :: file_freq = 6 !< file frequency as set in diag_table.yaml + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + integer, parameter :: kindl = KIND(0.0) !< compile-time default kind size + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_sum.nc", "read")) & + call mpp_error(FATAL, "unable to open test_sum.nc") + + if (.not. open_file(fileobj1, "test_sum_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open test_sum_regional.nc.0004") + + if (.not. open_file(fileobj2, "test_sum_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open test_sum_regional.nc.0005") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do ti = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_sum - time_level:", string(ti) + call read_data(fileobj, "var0_sum", cdata_out(1,1,1,1), unlim_dim_level=ti) + call check_data_0d(cdata_out(1,1,1,1), ti) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_sum - time_level:", string(ti) + call read_data(fileobj, "var1_sum", cdata_out(:,1,1,1), unlim_dim_level=ti) + call check_data_1d(cdata_out(:,1,1,1), ti) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_sum - time_level:", string(ti) + call read_data(fileobj, "var2_sum", cdata_out(:,:,1,1), unlim_dim_level=ti) + call check_data_2d(cdata_out(:,:,1,1), ti) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_sum - time_level:", string(ti) + call read_data(fileobj, "var3_sum", cdata_out(:,:,:,1), unlim_dim_level=ti) + call check_data_3d(cdata_out(:,:,:,1), ti, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var4_sum - time_level:", string(ti) + call read_data(fileobj, "var4_sum", cdata_out(:,:,:,:), unlim_dim_level=ti) + call check_data_3d(cdata_out(:,:,:,1), ti, .false.) + call check_data_3d(cdata_out(:,:,:,2), ti, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z - time_level:", string(ti) + call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti) + call check_data_3d(cdata_out(:,:,1:2,1), ti, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_sum in the first regional file- time_level:", string(ti) + call read_data(fileobj1, "var3_sum", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=ti) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), ti, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_sum in the second regional file- time_level:", string(ti) + call read_data(fileobj2, "var3_sum", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=ti) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), ti, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + ! sent data set to: + ! buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + & + ! real(j, kind=r8_kind)* 10_r8_kind + & + ! real(k, kind=r8_kind) + ! + time_index/100 + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + integer :: i, step_sum = 0 !< sum of time step increments to use in generating reference data + + ! sums integers for decimal part of field input + ! ie. level 1 = 1+2+..+6 + ! 2 = 7+8+..+12 + step_sum = 0 + do i=(time_level-1)*file_freq+1, time_level*file_freq + step_sum = step_sum + i + enddo + + ! 0d answer is: + ! (1011 * frequency sum'd over ) + ! + ( 1/100 * sum of time step increments ) + buffer_exp = real((1000.0_r8_kind+10.0_r8_kind+1.0_r8_kind) * file_freq + & + real(step_sum,r8_kind)/100.0_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0.0) then + print *, mpp_pe(), time_level, buffer_exp, buffer + call mpp_error(FATAL, "Check_time_sum::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + integer :: step_sum !< sum of time step increments to use in generating reference data + integer :: ii, i, j, k, l !< For looping + integer :: n + + step_sum = 0 + do i=(time_level-1)*file_freq+1, time_level*file_freq + step_sum = step_sum + i + enddo + + ! 1d answer is + ! ((i * 1000 + 11) * frequency) + (sum of time steps) + do ii = 1, size(buffer, 1) + buffer_exp = 0.0 + ! fails with both precisions + !do n=(time_level-1)*file_freq+1, time_level*file_freq + ! buffer_exp = real(buffer_exp + 1000.0_r8_kind * ii + 11.0_r8_kind + (n/100.0_r8_kind), r4_kind) + !enddo + ! passes with r8 defaults, fails with r4 + buffer_exp = real( & + file_freq * (real(ii, kind=r8_kind)*1000.0_r8_kind +10.0_r8_kind+1.0_r8_kind) + & + real(step_sum, kind=r8_kind)/100.0_r8_kind & + , kind=r4_kind) + + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0.0) then + print *, "i:", ii, "read in:", buffer(ii), "expected:", buffer_exp, "sum of time steps:", step_sum + print *, "diff:", abs(buffer(ii) - buffer_exp) + call mpp_error(FATAL, "Check_time_sum::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer :: ii,i, j, k, l !< For looping + integer :: step_sum !< sum of time step increments to use in generating reference data + + step_sum = 0 + do i=(time_level-1)*file_freq+1, time_level*file_freq + step_sum = step_sum + i + enddo + + ! 2d answer is + ! ((i * 1000 + j * 10 + 1) * frequency) + (sum of time steps) + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 6000.0_kindl+ & + 60.0_kindl*real(j, kind=r8_kind)+6.0_kindl + & + real(step_sum, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0.0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_sum::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, i, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + integer :: step_sum!< sum of time step increments to use in generating reference data + + step_sum = 0 + do i=(time_level-1)*file_freq+1, time_level*file_freq + step_sum = step_sum + i + enddo + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + ! 3d answer is + ! ((i * 1000 + j * 10 + k) * frequency) + (sum of time steps) + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 6000.0_kindl + & + 60.0_kindl*real(j+ny_oset, kind=r8_kind) + & + 6.0_kindl*real(k+nz_oset, kind=r8_kind) + & + real(step_sum, kind=r8_kind)/100.0_kindl, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0.0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_sum::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90 new file mode 100644 index 0000000000..bdaaa10c9d --- /dev/null +++ b/test_fms/diag_manager/test_diag_buffer.F90 @@ -0,0 +1,134 @@ +!*********************************************************************** +!* 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 output buffer functionality +program test_diag_buffer +#ifdef use_yaml + + use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type + use platform_mod, only: r8_kind, r4_kind, i8_kind, i4_kind + use fms_mod, only: string, fms_init, fms_end + use mpp_mod, only: mpp_error, FATAL + use diag_data_mod, only: i4, i8, r4, r8, time_none, EMPTY + + implicit none + + type(fmsDiagOutputBuffer_type) :: buffobj(6) !< Dummy output buffers + integer :: buff_sizes(5) !< Size of the buffer for each dimension + class(*),allocatable :: p_val(:,:,:,:,:) !< Dummy variable to get the data + integer :: i, j !< For do loops + real(r8_kind) :: r8_data !< Dummy r8 data + real(r4_kind) :: r4_data !< Dummy r4 data + integer(i8_kind) :: i8_data !< Dummy i8 data + integer(i4_kind) :: i4_data !< Dummy i4 data + character(len=4) :: fname = 'test' !< Dummy name for error messages + + call fms_init + + !< Test the r8_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer(time_none, fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (real(kind=r8_kind)) + if (any(p_val .ne. real(EMPTY, kind=r8_kind))) & + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + + !< Test the r4_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer(time_none, fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (real(kind=r4_kind)) + if (any(p_val .ne. real(EMPTY, kind=r4_kind))) & + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + + !< Test the i8_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer(time_none, fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (integer(kind=i8_kind)) + if (any(p_val .ne. int(EMPTY, kind=i8_kind))) & + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + + !< Test the i4_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer(time_none, fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (integer(kind=i4_kind)) + if (any(p_val .ne. int(EMPTY, kind=i4_kind))) & + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + + call fms_end() +#endif +end program 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..5fbd4a8356 --- /dev/null +++ b/test_fms/diag_manager/test_diag_dlinked_list.F90 @@ -0,0 +1,225 @@ +!*********************************************************************** +!* 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_set_stack_size, mpp_init_test_requests_allocated + 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 + + implicit none + + !> @brief This class is the type for the data to insert in the linked list. + type TestDummy_t + integer :: id = 0 + real :: weight = 1000 + 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 + !! + + call mpp_init(mpp_init_test_requests_allocated) + 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 + allocate(list) + call list%initialize() + + if( list%size() /= 0) then + test_passed = .false. + call error_mesg("test_diag_linked_list", "list incorrect size. Expected 0 at start",FATAL) + endif + + !! 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 : + p_td_obj%id = id + p_td_obj%weight = id + 1000 + !! 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 error_mesg("test_diag_dlinked_list", "List push_back error.",FATAL) + endif + + enddo + + if( list%size() /= num_objs) then + test_passed = .false. + call error_mesg("test_diag_dlinked_list", "List has incorrect size after inserts.",FATAL) + 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 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 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() + !! 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 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)). + 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 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 error_mesg("test_diag_dlinked_list", & + "List is incorrect size after clearing.",FATAL) + endif + + !! 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( 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" + pdo => pci + class default + 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 (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 => 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 = the_list%get_literator() + do while( iter%has_data() .eqv. .true.) + p_obj => iter%get() + p_td_obj => get_typed_data (p_obj ) + rsum = rsum + p_td_obj%id + ic_status = iter%next() + end do + end function sum_ids_in_list + + !> 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 (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 => null() !< A pointer to a class(*) object + integer :: ic_status !< A list insertion status. + !! + pdo=>null() + iter = the_list%get_literator() + do while( iter%has_data() .eqv. .true.) + p_obj => iter%get() + pdo => get_typed_data (p_obj ) + ic_status = iter%next() + end do + end function find_back_of_list + +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 a625db4d1e..4f44ea7ffe 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -45,7 +45,7 @@ setup_test () { &diag_manager_nml max_field_attributes=3 debug_diag_manager=.true. - use_mpp_io = .false. + do_diag_field_log=.true. / &ensemble_nml @@ -73,7 +73,7 @@ test_expect_success "Data array is too large in x and y direction (test $my_test mpirun -n 1 ../test_diag_manager ' -my_test_count=2 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_02 1 3 1 0 0 0 @@ -89,7 +89,7 @@ test_expect_success "Data array is too large in x direction (test $my_test_count mpirun -n 1 ../test_diag_manager ' -my_test_count=3 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_03 1 3 1 0 0 0 @@ -105,7 +105,7 @@ test_expect_success "Data array is too large in y direction (test $my_test_count mpirun -n 1 ../test_diag_manager ' -my_test_count=4 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_04 1 3 1 0 0 0 @@ -123,7 +123,7 @@ test_expect_success "Data array is too small in x and y direction, checks for 2 mpirun -n 1 ../test_diag_manager ' -my_test_count=5 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_05 1 3 1 0 0 0 @@ -141,7 +141,7 @@ test_expect_success "Data array is too small in x directions, checks for 2 time mpirun -n 1 ../test_diag_manager ' -my_test_count=6 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_06 1 3 1 0 0 0 @@ -159,7 +159,7 @@ test_expect_success "Data array is too small in y direction, checks for 2 time s mpirun -n 1 ../test_diag_manager ' -my_test_count=7 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_07 1 3 1 0 0 0 @@ -175,7 +175,7 @@ test_expect_success "Data array is too large in x and y, with halos, 2 time step mpirun -n 1 ../test_diag_manager ' -my_test_count=8 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_08 1 3 1 0 0 0 @@ -193,7 +193,7 @@ test_expect_success "Data array is too small in x and y, with halos, 2 time step mpirun -n 1 ../test_diag_manager ' -my_test_count=9 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_09 1 3 1 0 0 0 @@ -209,7 +209,7 @@ test_expect_success "Data array is too small, 1D, static global data (test $my_t mpirun -n 1 ../test_diag_manager ' -my_test_count=10 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_10 1 3 1 0 0 0 @@ -225,7 +225,7 @@ test_expect_success "Data array is too large, 1D, static global data (test $my_t mpirun -n 1 ../test_diag_manager ' -my_test_count=11 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_11 1 3 1 0 0 0 @@ -241,7 +241,7 @@ test_expect_success "Missing je_in as an input (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=12 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_12 1 3 1 0 0 0 @@ -260,7 +260,7 @@ test_expect_success "Catch duplicate field in diag_table (test $my_test_count)" mpirun -n 1 ../test_diag_manager ' -my_test_count=13 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_13 1 3 1 0 0 0 @@ -280,7 +280,7 @@ test_expect_success "Output interval greater than runlength (test $my_test_count mpirun -n 1 ../test_diag_manager ' -my_test_count=14 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_14 1990 1 29 0 0 0 @@ -297,7 +297,7 @@ test_expect_success "Catch invalid date in register_diag_field call (test $my_te mpirun -n 1 ../test_diag_manager ' -my_test_count=15 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_15 1 3 1 0 0 0 @@ -314,7 +314,7 @@ test_expect_success "OpenMP thread test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=16 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_16 1 3 1 0 0 0 @@ -331,7 +331,7 @@ test_expect_success "Filename appendix added (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=17 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_17 1 3 1 0 0 0 @@ -348,7 +348,7 @@ test_expect_success "Root-mean-square (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=18 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_18 1 3 1 0 0 0 @@ -368,7 +368,7 @@ test_expect_success "Added attributes, and cell_measures (test $my_test_count)" mpirun -n 1 ../test_diag_manager ' -my_test_count=19 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_19 1 3 1 0 0 0 @@ -387,7 +387,7 @@ test_expect_success "Area and Volume same field (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=20 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_20 1 3 1 0 0 0 @@ -406,7 +406,7 @@ test_expect_success "Get diag_field_id, ID found and not found (test $my_test_co mpirun -n 1 ../test_diag_manager ' -my_test_count=21 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_21 1 3 1 0 0 0 @@ -423,7 +423,7 @@ test_expect_success "Add axis attributes (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=22 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_22 1 3 1 0 0 0 @@ -440,7 +440,7 @@ test_expect_success "Get 'nv' axis id (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' -my_test_count=23 +my_test_count=`expr $my_test_count + 1` cat <<_EOF > diag_table test_diag_manager_23 1990 1 1 0 0 0 @@ -459,8 +459,7 @@ setup_test test_expect_success "Unstructured grid (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' - -my_test_count=24 +my_test_count=`expr $my_test_count + 1` # test_diag_manager_time cat <<_EOF > diag_table test_diag_manager @@ -479,7 +478,6 @@ test_diag_manager "test_diag_manager_mod", "sst", "sst", "ocn_end%4yr%2mo%2dy%2hr", "all", .true., "none", 2 _EOF -my_test_count=25 rm -f input.nml && touch input.nml test_expect_success "wildcard filenames (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time @@ -499,12 +497,376 @@ test_diag_manager "test_diag_manager_mod", "sst", "sst", "test_diurnal", "all", "diurnal3", "none", 2 "test_diag_manager_mod", "ice", "ice", "test_diurnal", "all", "diurnal3", "none", 2 _EOF + +my_test_count=`expr $my_test_count + 1` test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' setup_test -my_test_count=26 +my_test_count=`expr $my_test_count + 1` test_expect_success "Test the diag update_buffer (test $my_test_count)" ' mpirun -n 1 ../test_diag_update_buffer ' - test_done +## uses some updated code but doesn't need flag +my_test_count=`expr $my_test_count + 1` +test_expect_success "test_diag_dlinked_list (test $my_test_count)" ' + mpirun -n 1 ../test_diag_dlinked_list +' + +## run tests that are ifdef'd out only if compiled with yaml +## otherwise just run the updated end to end to check for error +if [ -z "${skipflag}" ]; then + + cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: wild_card_name%4yr%2mo%2dy%2hr + filename_time: end + freq: 6 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours + varlist: + - module: test_diag_manager_mod + var_name: sst + output_name: sst + reduction: average + kind: r4 + global_meta: + - is_a_file: true +- file_name: normal + freq: 24 days + time_units: hours + unlimdim: records + varlist: + - module: test_diag_manager_mod + var_name: sst + output_name: sst + reduction: average + kind: r4 + write_var: true + attributes: + - do_sst: .true. + sub_region: + - grid_type: latlon + corner1: -80, 0 + corner2: -80, 75 + corner3: -60, 0 + corner4: -60, 75 +- file_name: normal2 + freq: -1 + time_units: hours + unlimdim: records + write_file: true + varlist: + - module: test_diag_manager_mod + var_name: sstt + output_name: sstt + reduction: average + kind: r4 + long_name: S S T + - module: test_diag_manager_mod + var_name: sstt2 + output_name: sstt2 + reduction: average + kind: r4 + long_name: S S T + write_var: false + sub_region: + - grid_type: index + tile: 1 + corner1: 10, 15 + corner2: 20, 15 + corner3: 10, 25 + corner4: 20, 25 +- file_name: normal3 + freq: -1 + time_units: hours + unlimdim: records + write_file: false +_EOF + cp diag_table.yaml diag_table.yaml_base + + my_test_count=`expr $my_test_count + 1` + test_expect_success "diag_yaml test (test $my_test_count)" ' + mpirun -n 1 ../test_diag_yaml + ' + . $top_srcdir/test_fms/diag_manager/check_crashes.sh + my_test_count = `expr $my_test_count + 14` + + printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml + cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: file1 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: test_diag_manager_mod + var_name: sst1 + output_name: sst1 + reduction: average + kind: r4 +- file_name: file2 + freq: 6 hours + time_units: hours + unlimdim: time + is_ocean: True + varlist: + - module: test_diag_manager_mod + var_name: sst2 + output_name: sst2 + reduction: average + kind: r4 +- file_name: file3 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: test_diag_manager_mod + var_name: sst3 + output_name: sst3 + reduction: average + kind: r4 + - module: test_diag_manager_mod + var_name: sst4 + output_name: sst4 + reduction: average + kind: r4 +_EOF + + my_test_count=`expr $my_test_count + 1` + test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" ' + mpirun -n 2 ../test_diag_ocean + ' + + + printf "&diag_manager_nml \n use_modern_diag = .true. \n do_diag_field_log = .true. \n/" | cat > input.nml + cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 + +diag_files: +- file_name: static_file + freq: -1 + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var7 + reduction: none + kind: r4 + global_meta: + - is_important: False + has_important: True +- file_name: file1 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: potato + reduction: average + kind: r4 +- file_name: file2 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var3 + reduction: average + kind: r4 + - module: atm_mod + var_name: var4 + output_name: i_on_a_sphere + reduction: average + kind: r8 + - module: atm_mod + var_name: var6 + reduction: average + kind: r8 + - module: atm_mod + var_name: var4 + output_name: var4_bounded + reduction: average + kind: r8 + zbounds: 2.0 3.0 +- file_name: file3 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: lnd_mod + var_name: var5 + reduction: average + kind: r4 + - module: lnd_mod + var_name: var7 + reduction: average + kind: r4 +- file_name: file4 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: lnd_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file5 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var4 + reduction: average + kind: r4 + sub_region: + - grid_type: index + tile: 1 + corner1: 10, 15 + corner2: 20, 15 + corner3: 10, 25 + corner4: 20, 25 +- file_name: file6%4yr%2mo%2dy%2hr + freq: 6 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file7 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var1 + reduction: none + kind: r4 + attributes: + - GFDL_name: var_var +- file_name: file8%4yr%2mo%2dy%2hr%2min + freq: 1 hours,1 hours,1 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours, 3 hours, 1 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours, 3 hours, 9 hours + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file9%4yr%2mo%2dy%2hr%2min + filename_time: begin + freq: 1 hours,1 hours,1 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours, 3 hours, 1 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours, 3 hours, 9 hours + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file10_diurnal + freq: 1 days + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var1 + reduction: diurnal12 + kind: r4 +_EOF + + my_test_count=`expr $my_test_count + 1` + test_expect_success "buffer functionality (test $my_test_count)" ' + mpirun -n 1 ../test_diag_buffer + ' + + my_test_count=`expr $my_test_count + 1` + test_expect_success "Test the modern diag manager end to end (test $my_test_count)" ' + mpirun -n 6 ../test_modern_diag + ' + +printf "&diag_manager_nml \n use_modern_diag = .true. \n use_clock_average = .true. \n /" | cat > input.nml +cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 + +diag_files: +- file_name: file1_clock + freq: 1 days + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var1 + reduction: average + kind: r4 +_EOF + +my_test_count=`expr $my_test_count + 1` + test_expect_success "Test the modern diag manager with use_clock_average = .true. (test $my_test_count)" ' + mpirun -n 1 ../test_flexible_time + ' + +printf "&diag_manager_nml \n use_modern_diag = .true. \n use_clock_average = .false. \n /" | cat > input.nml +cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 + +diag_files: +- file_name: file1_forecast + freq: 1 days + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var1 + reduction: average + kind: r4 + output_name: var1_min + - module: atm_mod + var_name: var1 + reduction: average + kind: r4 + output_name: var2_max +_EOF + +my_test_count=`expr $my_test_count + 1` + test_expect_success "Test the modern diag manager with use_clock_average = .false. (test $my_test_count)" ' + mpirun -n 1 ../test_flexible_time + ' +printf "&diag_manager_nml \n use_modern_diag = .false. \n use_clock_average = .true. \n /" | cat > input.nml + test_expect_failure "Test if use_modern_diag = .false. and use_clock_average = .true. fails (test $my_test_count)" ' + mpirun -n 1 ../test_flexible_time + ' + +else + my_test_count=`expr $my_test_count + 1` + test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" ' + mpirun -n 6 ../test_modern_diag + ' +fi +test_done 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..509032e6e4 --- /dev/null +++ b/test_fms/diag_manager/test_diag_object_container.F90 @@ -0,0 +1,239 @@ +!*********************************************************************** +!* 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_set_stack_size, mpp_init_test_requests_allocated + 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 + 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 (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 + !! + 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 + !! + + + call mpp_init(mpp_init_test_requests_allocated) + 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 + allocate(container) + call container%initialize() + !!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 error_mesg('test_diag_object_container', 'Container incorrect size. Expected 0 at start',FATAL) + 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 error_mesg('test_diag_object_container', 'Container Insertion error.',FATAL) + endif + enddo + + if( container%size() /= num_objs) then + test_passed = .false. + 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 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 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; + 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 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 error_mesg('test_diag_object_container', 'The container size is not as expected post inserts.',FATAL) + 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 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 error_mesg('test_diag_object_container','The_container%size() \= num_obj -1 after a removal ',FATAL) + 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 error_mesg('test_diag_object_container', 'Container incorrect id sums post removal of 4',FATAL) + 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 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 error_mesg('test_diag_object_container', 'Id of returned object was not 7 ',FATAL) + 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 error_mesg('test_diag_object_container', 'Container is incorrect size after clearing.',FATAL) + endif + + !! And the container has a finalize/destructor which will deallocate the list and data. + deallocate(container) + + call error_mesg('test_diag_object_container', 'Test has finished',NOTE) + +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 + + diff --git a/test_fms/diag_manager/test_diag_ocean.F90 b/test_fms/diag_manager/test_diag_ocean.F90 new file mode 100644 index 0000000000..449569dd49 --- /dev/null +++ b/test_fms/diag_manager/test_diag_ocean.F90 @@ -0,0 +1,100 @@ +!*********************************************************************** +!* 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_model_subset feature of diag_mananger_init +!! It requires two PEs to run and it runs with diag_table_yaml_27 +program test_diag_ocean + +#ifdef use_yaml +use FMS_mod, only: fms_init, fms_end, string +use fms_diag_yaml_mod +use diag_manager_mod, only: diag_manager_init +use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_OTHER +use mpp_mod +use platform_mod + +implicit none + +type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init +type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml +type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml +character(len=10), allocatable :: file_names(:) !< The expected names of the files +character(len=10), allocatable :: var_names(:) !< The expected names of the variables +integer :: diag_subset !< Diag_subset to be sent to diag_manager_init +integer :: nfiles !< Expected number of files +integer :: nvariables !< Expected number of variables +integer :: i !< For do loops + +call fms_init() + +if (mpp_npes() .ne. 2) call mpp_error(FATAL, "test_diag_ocean requires two PEs!") + +!> PE 0 is not going to include the file with is_ocean = .true. +if (mpp_pe() .eq. 0) then + diag_subset = DIAG_OTHER + nfiles = 2 + allocate(file_names(nfiles)) + file_names = (/"file1", "file3"/) + nvariables = 3 + allocate(var_names(nvariables)) + var_names = (/"sst1", "sst3", "sst4"/) +endif + +!> PE 1 is only going to include the file with is_ocean = .true. +if (mpp_pe() .eq. 1) then + diag_subset = DIAG_OCEAN + nfiles = 1 + allocate(file_names(nfiles)) + file_names = (/"file2"/) + nvariables = 1 + allocate(var_names(nvariables)) + var_names = (/"sst2"/) +endif + +call diag_manager_init(diag_model_subset=diag_subset) + +my_yaml = get_diag_yaml_obj() +diag_files = my_yaml%get_diag_files() +if (size(diag_files) .ne. nfiles) call mpp_error(FATAL, "The number of files should be "//string(nfiles)) + +do i = 1, nfiles + if(trim(file_names(i)) .ne. diag_files(i)%get_file_fname()) & + call mpp_error(FATAL, "The file_name should of the "//string(i)//" file should be "//& + &trim(file_names(i))//" not "//diag_files(i)%get_file_fname()) +end do + +diag_fields = my_yaml%get_diag_fields() +if (size(diag_fields) .ne. nvariables) call mpp_error(FATAL, "The number of variables should be "//string(nvariables)) + +do i = 1, nvariables + if(trim(var_names(i)) .ne. diag_fields(i)%get_var_varname()) & + call mpp_error(FATAL, "The var_name should of the "//string(i)//" field should be "//& + &trim(var_names(i))//" not "//diag_fields(i)%get_var_varname()) +end do + +deallocate(diag_files) +deallocate(diag_fields) +deallocate(file_names) +deallocate(var_names) + +call diag_yaml_object_end +call fms_end() + +#endif +end program test_diag_ocean \ No newline at end of file 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..3024412854 --- /dev/null +++ b/test_fms/diag_manager/test_diag_yaml.F90 @@ -0,0 +1,394 @@ +!*********************************************************************** +!* 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 + +use FMS_mod, only: fms_init, fms_end +use fms_diag_yaml_mod +use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, & + & get_base_minute, get_base_second, diag_data_init, DIAG_HOURS, DIAG_NULL, DIAG_DAYS, & + & time_average, r4, middle_time, end_time +use time_manager_mod, only: set_calendar_type, JULIAN +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 + +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 +integer, allocatable :: indices(:) !< Array of indices + +#ifdef use_yaml +type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml +type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml +type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init +type(diagYamlObject_type) :: ans !< expected diagYamlObject +integer, ALLOCATABLE :: diag_files_ids(:) !< Ids of the diag_files +#endif + +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') + +#ifndef use_yaml +if (checking_crashes) call mpp_error(FATAL, "It is crashing!") +call fms_end() +#else + +call set_calendar_type(JULIAN) +call diag_data_init() +call diag_yaml_object_init(DIAG_ALL) + +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 check_base_time() + + 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) !< the fourth file has file_write = false so it doesn't count + call compare_diag_files(diag_files) + + diag_fields = my_yaml%get_diag_fields() + call compare_result("nfields", size(diag_fields), 3) !< the fourth variable has var_write = false so it doesn't count + call compare_diag_fields(diag_fields) + + !< Check that get_num_unique_fields is getting the correct number of unique fields + call compare_result("number of unique fields", get_num_unique_fields(), 2) + + deallocate(diag_files) + deallocate(diag_fields) + + indices = find_diag_field("sst", "test_diag_manager_mod") + print *, "sst was found in ", indices + if (size(indices) .ne. 2) & + call mpp_error(FATAL, 'sst was supposed to be found twice!') + if (indices(1) .ne. 2 .and. indices(2) .ne. 1) & + call mpp_error(FATAL, 'sst was supposed to be found in indices 1 and 2') + + diag_fields = get_diag_fields_entries(indices) + call compare_result("sst - nfields", size(diag_fields), 2) + call compare_result("sst - fieldname", diag_fields(1)%get_var_varname(), "sst") + call compare_result("sst - fieldname", diag_fields(2)%get_var_varname(), "sst") + deallocate(diag_fields) + + diag_files_ids = get_diag_files_id(indices) + allocate(diag_files(size(diag_files_ids))) + + diag_files(1) = my_yaml%diag_files(diag_files_ids(1)) + diag_files(2) = my_yaml%diag_files(diag_files_ids(2)) + call compare_result("sst - nfiles", size(diag_files), 2) + call compare_result("sst - filename", diag_files(1)%get_file_fname(), "normal") + call compare_result("sst - filename", diag_files(2)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr") + deallocate(diag_files) + deallocate(indices) + + indices = find_diag_field("sstt", "test_diag_manager_mod") + print *, "sstt was found in ", indices + if (size(indices) .ne. 1) & + call mpp_error(FATAL, 'sstt was supposed to be found twice!') + if (indices(1) .ne. 3) & + call mpp_error(FATAL, 'sstt was supposed to be found in indices 1 and 2') + deallocate(indices) + + indices = find_diag_field("sstt2", "test_diag_manager_mod") !< This is in diag_table but it has write_var = false + print *, "sstt2 was found in ", indices + if (indices(1) .ne. -999) & + call mpp_error(FATAL, "sstt2 is not in the diag_table!") + + indices = find_diag_field("tamales", "test_diag_manager_mod") + print *, "tamales was found in ", indices + if (indices(1) .ne. -999) & + call mpp_error(FATAL, "tamales is not in the diag_table!") + +endif + +!! test dump routines +call dump_diag_yaml_obj('test_dump.log') +call dump_diag_yaml_obj() ! to stdout + +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(), time_average) + call compare_result("var_reduction 2", res(2)%get_var_reduction(), time_average) + call compare_result("var_reduction 3", res(3)%get_var_reduction(), time_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_kind 1", res(1)%get_var_kind(), r4) + call compare_result("var_kind 2", res(2)%get_var_kind(), r4) + call compare_result("var_kind 3", res(3)%get_var_kind(), r4) + + 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("get_filename_time 1", res(1)%get_filename_time(), end_time) + call compare_result("get_filename_time 2", res(2)%get_filename_time(), middle_time) + call compare_result("get_filename_time 3", res(3)%get_filename_time(), middle_time) + + 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(), -1) + + call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), DIAG_HOURS) + call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), DIAG_DAYS) + call compare_result("file_frequnit 3", res(3)%get_file_frequnit(), DIAG_DAYS) + + call compare_result("file_timeunit 1", res(1)%get_file_timeunit(), DIAG_HOURS) + call compare_result("file_timeunit 2", res(2)%get_file_timeunit(), DIAG_HOURS) + call compare_result("file_timeunit 3", res(3)%get_file_timeunit(), DIAG_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_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(), 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(), DIAG_HOURS) + call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), DIAG_NULL) + call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), DIAG_NULL) + + call compare_result("file_duration 1", res(1)%get_file_duration(), 12) + 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(), DIAG_HOURS) + call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), DIAG_NULL) + call compare_result("file_duration_units 3", res(3)%get_file_duration_units(), DIAG_NULL) + + 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 + +!> @brief Check if the base_time saved in diag_data is correct +subroutine check_base_time() + integer :: base_time_mod_var(6) !< The base_time obtained from diag_data + + base_time_mod_var(1) = get_base_year() + base_time_mod_var(2) = get_base_month() + base_time_mod_var(3) = get_base_day() + base_time_mod_var(4) = get_base_hour() + base_time_mod_var(5) = get_base_minute() + base_time_mod_var(6) = get_base_second() + + call compare_result("base_time", base_time_mod_var, (/2, 1, 1, 0, 0 ,0 /)) +end subroutine check_base_time + +#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)//".") + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + end select + end select +end subroutine compare_result_1d +#endif diff --git a/test_fms/diag_manager/test_flexible_time.F90 b/test_fms/diag_manager/test_flexible_time.F90 new file mode 100644 index 0000000000..2dd881177d --- /dev/null +++ b/test_fms/diag_manager/test_flexible_time.F90 @@ -0,0 +1,69 @@ +!*********************************************************************** +!* 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 flexible timing capability in the modern diag_manager +program test_flexible_time +use fms_mod, only: fms_init, fms_end +use time_manager_mod, only: set_date, time_type, increment_date, set_calendar_type, & + JULIAN, set_time, operator(+) +use diag_manager_mod, only: diag_manager_init, diag_axis_init, register_diag_field, & + diag_manager_set_time_end, diag_send_complete, diag_manager_end, & + send_data +use mpp_mod, only: FATAL, mpp_error +use platform_mod, only: r8_kind + +implicit none + +real(kind=r8_kind) :: var_data(2) !< Dummy data +logical :: used !< .True. if send_data was sucessful +type(time_type) :: Time !< Time of the simulation +type(time_type) :: Time_step !< Start time of the simulation +type(time_type) :: End_Time !< End Time of the simulation +integer :: i +integer :: id_z, id_var + +call fms_init() +call set_calendar_type(JULIAN) +call diag_manager_init + +!< Starting time of the simulation +Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3 + +!< Set up a dummy variable +id_z = diag_axis_init('z', (/1. ,2. /), 'point_Z', 'z', long_name='point_Z') +id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Time, 'Var not domain decomposed', 'mullions') + +!< Set up the end of the simulation (i.e 2 days long) +End_Time = set_date(2,1,3,3,0,0) +call diag_manager_set_time_end(End_Time) + +!< Set up the simulation +Time_step = set_time (3600,0) !< 1 hour +do i=1,48 + var_data = real(i, kind=r8_kind) + Time = Time + Time_step + used = send_data(id_var, var_data, Time) + call diag_send_complete(set_time(3600,0)) +enddo + +call diag_manager_end(End_Time) + +call fms_end() + +end program test_flexible_time diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90 new file mode 100644 index 0000000000..8205b8eee1 --- /dev/null +++ b/test_fms/diag_manager/test_modern_diag.F90 @@ -0,0 +1,321 @@ +!*********************************************************************** +!* 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 modern diag_manager + +program test_modern_diag +use mpp_domains_mod, only: domain2d, mpp_domains_set_stack_size, mpp_define_domains, mpp_define_io_domain, & + mpp_define_mosaic, domainug, mpp_get_compute_domains, mpp_define_unstruct_domain, & + mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, & + mpp_get_UG_compute_domain +use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, & + diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, & + diag_manager_set_time_end, send_data, register_static_field, & + diag_field_add_cell_measures +use platform_mod, only: r8_kind, r4_kind +use fms_mod, only: fms_init, fms_end +use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file +use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+) +use fms_diag_object_mod,only: dump_diag_obj + +implicit none + +!> @brief Type to hold all the dummy data variables +type data_type + real(kind=r8_kind), allocatable :: var1(:,:) !< Dummy data for var1 + real(kind=r8_kind), allocatable :: var2(:,:) !< Dummy data for var2 + real(kind=r8_kind), allocatable :: var3(:,:) !< Dummy data for var3 + real(kind=r8_kind), allocatable :: var4(:,:,:) !< Dummy data for var4 + real(kind=r8_kind), allocatable :: var5(:) !< Dummy data for var5 + real(kind=r8_kind), allocatable :: var6(:) !< Dummy data for var6 +end type data_type + +type(time_type) :: Time !< Time of the simulation +type(time_type) :: Time_step !< Time_step of the simulation +integer, dimension(2) :: layout !< Layout to use when setting up the domain +integer, dimension(2) :: io_layout !< io layout to use when setting up the io domain +integer :: nx !< Number of x points +integer :: ny !< Number of y points +integer :: nz !< Number of z points +integer :: ug_dim_size !< Number of points in the UG +type(domain2d) :: Domain !< 2D domain +type(domain2d) :: Domain_cube_sph !< cube sphere domain +type(domainug) :: land_domain !< Unstructured domain +real, dimension(:), allocatable:: x !< X axis data +real, dimension(:), allocatable:: y !< Y axis_data +real, dimension(:), allocatable:: z !< Z axis_data +integer, dimension(:), allocatable:: ug_dim_data !< UG axis_data +integer :: i !< For do loops +integer :: id_x !< axis id for the x dimension +integer :: id_x3 !< axis id for the x dimension in the cube sphere domain +integer :: id_y !< axis id for the y dimension +integer :: id_y3 !< axis id for the y dimension in the cube sphere domain +integer :: id_UG !< axis id for the unstructured dimension +integer :: id_z !< axis id for the z dimention +integer :: id_z2 !< axis id for the z dimention +integer :: id_var1 !< diag_field id for var in lon/lat grid +integer :: id_var2 !< diag_field id for var in lat/lon grid +integer :: id_var3 !< diag_field id for var in cube sphere grid +integer :: id_var4 !< diag_field id for 3d var in cube sphere grid +integer :: id_var5 !< diag_field id for var in UG grid +integer :: id_var6 !< diag_field id for var that is not domain decomposed +integer :: id_var7 !< 1D var +integer :: id_var8 !< Scalar var +type(data_type) :: var_data !< Dummy variable data to send to diag_manager +logical :: used !< Used for send_data call +integer :: io_status !< Status after reading the namelist +logical :: debug = .false. !< Flag used to ignore the axis/field_ids checks in the test. + !! Useful when using a portion or a different diag_table.yaml + +namelist / test_modern_diag_nml / debug + +call fms_init +call set_calendar_type(JULIAN) +call diag_manager_init + +read (input_nml_file, test_modern_diag_nml, iostat=io_status) +if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml') + +nx = 96 +ny = 96 +nz = 5 +layout = (/1, mpp_npes()/) +io_layout = (/1, 1/) + +!> Set up a normal (lat/lon) 2D domain, a cube sphere, and UG domain +call set_up_2D_domain(domain, layout, nx, ny, io_layout) +call set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout) +call create_land_domain(Domain_cube_sph, nx, ny, 6, land_domain, npes_group=1) +call mpp_get_UG_compute_domain(land_domain, size=ug_dim_size) + +! Set up the data +allocate(x(nx), y(ny), z(nz)) +do i=1,nx + x(i) = i +enddo +do i=1,ny + y(i) = i +enddo +do i=1,nz + z(i) = i +enddo + +allocate(ug_dim_data(ug_dim_size)) +call mpp_get_UG_domain_grid_index(land_domain, ug_dim_data) +ug_dim_data = ug_dim_data - 1 + +! Set up the intial time +Time = set_date(2,1,1,0,0,0) + +! Register the diags axis +id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain) +id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain) + +id_x3 = diag_axis_init('x3', x, 'point_E', 'x', Domain2=Domain_cube_sph) +id_y3 = diag_axis_init('y3', y, 'point_E', 'y', Domain2=Domain_cube_sph) + +id_ug = diag_axis_init("grid_index", real(ug_dim_data), "none", "U", long_name="grid indices", & + set_name="land", DomainU=land_domain, aux="geolon_t geolat_t") + +id_z2 = diag_axis_init('z_edge', z, 'point_Z', 'z', long_name='point_Z') +id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z', edges = id_z2) + +call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)') +call diag_axis_add_attribute (id_z, 'integer', 10) +call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/)) +call diag_axis_add_attribute (id_z, 'real', 10.) +call diag_axis_add_attribute (id_x, '1d real', (/10./)) +call diag_axis_add_attribute (id_ug, 'compress', 'x y') + +if (.not. debug) then + if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id") + if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id") + if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id") + if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id") + if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id") + if (id_z2 .ne. 6) call mpp_error(FATAL, "The z2 axis does not have the expected id") + if (id_z .ne. 7) call mpp_error(FATAL, "The z axis does not have the expected id") +endif + +! Register the variables +id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions') +id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_y, id_x/), Time, & + 'Var in a lon/lat domain with flipped dimensions', 'mullions') +id_var3 = register_diag_field ('atm_mod', 'var3', (/id_x3, id_y3/), Time, 'Var in a cube sphere domain', 'mullions') +id_var4 = register_diag_field ('atm_mod', 'var4', (/id_x3, id_y3, id_z/), Time, & + '3D var in a cube sphere domain', 'mullions') +id_var5 = register_diag_field ('lnd_mod', 'var5', (/id_ug/), Time, 'Var in a UG domain', 'mullions') +id_var6 = register_diag_field ('atm_mod', 'var6', (/id_z/), Time, 'Var not domain decomposed', 'mullions') + +!< This has the same name as var1, but it should have a different id because the module is different +!! so it should have its own diag_obj +id_var7 = register_diag_field ('lnd_mod', 'var1', Time, 'Some scalar var', 'mullions') +id_var8 = register_static_field ('atm_mod', 'var7', (/id_z/), "Be static!", "none") + +if (.not. debug) then + if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id") + if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id") + if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id") + if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id") + if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id") + if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id") + if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id") + if (id_var8 .ne. 8) call mpp_error(FATAL, "var8 does not have the expected id") +endif + +call diag_field_add_cell_measures(id_var6, area=id_var8, volume=id_var8) + +call diag_field_add_attribute (id_var1, "some string", "this is a string") +call diag_field_add_attribute (id_var1, "integer", 10) +call diag_field_add_attribute (id_var1, "1d_integer", (/10, 10/)) +call diag_field_add_attribute (id_var1, "real", 10.) +call diag_field_add_attribute (id_var2, '1d_real', (/10./)) +call diag_field_add_attribute (id_var2, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)') +call diag_field_add_attribute (id_var2, 'cell_methods', 'area: mullions') + +!! test dump routines +!! prints fields from objects for debugging to log if name is provided, othwerise goes to stdout +call dump_diag_obj('diag_obj_dump.log') +call dump_diag_obj() + +call diag_manager_set_time_end(Time) +call diag_manager_set_time_end(set_date(2,1,2,0,0,0)) + +call allocate_dummy_data(var_data, domain, Domain_cube_sph, land_domain, nz) +Time_step = set_time (3600,0) !< 1 hour +do i=1,23 + Time = Time + Time_step + call set_dummy_data(var_data, i) + used = send_data(id_var1, var_data%var1, Time) + used = send_data(id_var2, var_data%var2, Time) + used = send_data(id_var3, var_data%var3, Time) + used = send_data(id_var4, var_data%var4, Time) + used = send_data(id_var5, var_data%var5, Time) + used = send_data(id_var6, var_data%var6, Time) + used = send_data(id_var7, var_data%var6, Time) + + !TODO I don't know about this (scalar field) or how this is suppose to work #WUT + used = send_data(id_var8, var_data%var6, Time) + + call diag_send_complete(Time_step) +enddo +call deallocate_dummy_data(var_data) + +call diag_manager_end(Time) +call fms_end + +contains + +include "../fms2_io/create_atmosphere_domain.inc" +include "../fms2_io/create_land_domain.inc" + +!> @brief Allocates the dummy data to send to send_data +subroutine allocate_dummy_data(var, lat_lon_domain, cube_sphere, lnd_domain, nz) + type(data_type), intent(inout) :: var !< Data var to allocate + type(domain2d), intent(in) :: lat_lon_domain !< Lat/Lon domain + type(domain2d), intent(in) :: cube_sphere !< Cube sphere domain + type(domainug), intent(in) :: lnd_domain !< Land domain + integer, intent(in) :: nz !< Number of Z points + + integer :: nland !< Size of the unstructured grid per PE + integer :: is !< Starting x compute index + integer :: ie !< Ending x compute index + integer :: js !< Starting y compute index + integer :: je !< Ending y compute index + + call mpp_get_compute_domain(lat_lon_domain, is, ie, js, je) + allocate(var%var1(is:ie, js:je)) !< Variable in a lat/lon domain + allocate(var%var2(js:je, is:ie)) !< Variable in a lat/lon domain with flipped dimensions + + call mpp_get_compute_domain(cube_sphere, is, ie, js, je) + allocate(var%var3(is:ie, js:je)) !< Variable in a cube sphere domain + allocate(var%var4(is:ie, js:je, nz)) !< Variable in a 3D cube sphere domain + + call mpp_get_UG_compute_domain(lnd_domain, size=nland) + allocate(var%var5(nz)) !< Variable in the land unstructured domain + + allocate(var%var6(nz)) !< 1D variable not domain decomposed + +end subroutine allocate_dummy_data + +!> @brief Allocates the dummy data to send to send_data +subroutine deallocate_dummy_data(var) + type(data_type), intent(inout) :: var !< Data var to deallocate + + deallocate(var%var1, var%var2, var%var3, var%var4, var%var5, var%var6) +end subroutine deallocate_dummy_data + +!> @brief Sets the dummy_data to use in send_data +subroutine set_dummy_data(var, data_value) + type(data_type), intent(inout) :: var !< Data type to set + integer, intent(in) :: data_value !< Value to send the data as + + var%var1 = real(data_value, kind=r8_kind) + var%var2 = real(data_value + 1, kind=r8_kind) + var%var3 = real(data_value + 2, kind=r8_kind) + var%var4 = real(data_value + 3, kind=r8_kind) + var%var5 = real(data_value + 4, kind=r8_kind) + var%var6 = real(data_value + 5, kind=r8_kind) + +end subroutine set_dummy_data + +!> @brief Sets up a lat/lon domain +subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout) + type(domain2d), intent(out) :: Domain !< 2D domain + integer, intent(in) :: layout(:) !< Layout to use when setting up the domain + integer, intent(in) :: nx !< Number of x points + integer, intent(in) :: ny !< Number of y points + integer, intent(in) :: io_layout(:) !< Io layout to use when setting up the io_domain + + call mpp_domains_set_stack_size(17280000) + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain') + call mpp_define_io_domain(Domain, io_layout) +end subroutine set_up_2D_domain + +!> @brief Sets up a cube sphere domain +subroutine set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout) + type(domain2d), intent(out) :: Domain_cube_sph !< 2D domain + integer, intent(in) :: nx !< Number of x points + integer, intent(in) :: ny !< Number of y points + integer, intent(in) :: io_layout(:) !< Io layout to use when setting up the io_domain + + integer :: i !< For do loops + integer :: npes !< Number of pes + integer, parameter :: ntiles=6 !< Number of tiles + integer, dimension(4,ntiles) :: global_indices !< The global indices of each tile + integer, dimension(2,ntiles) :: layout !< The layout of each tile + integer, dimension(ntiles) :: pe_start !< The starting PE of each tile + integer, dimension(ntiles) :: pe_end !< The ending PE of eeach tile + + npes = mpp_npes() + + !< Create the domain + do i = 1,ntiles + global_indices(:, i) = (/1, ny, 1, ny/) + layout(:, i) = (/1, npes/ntiles/) + pe_start(i) = (i-1)*(npes/ntiles) + pe_end(i) = i*(npes/ntiles) - 1 + end do + + call create_atmosphere_domain((/nx, nx, nx, nx, nx, nx/), & + (/ny, ny, ny, ny, ny, ny/), & + global_indices, layout, pe_start, pe_end, & + io_layout, Domain_cube_sph) +end subroutine set_up_cube_sph_domain +end program test_modern_diag diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 new file mode 100644 index 0000000000..d47d21895e --- /dev/null +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -0,0 +1,363 @@ +!*********************************************************************** +!* 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 General program to test the different possible reduction methods +program test_reduction_methods + use fms_mod, only: fms_init, fms_end + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + use platform_mod, only: r8_kind + use block_control_mod, only: block_control_type, define_blocks + use mpp_mod, only: mpp_sync, FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file + use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+) + use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, & + diag_send_complete, diag_manager_set_time_end, send_data + use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, & + mpp_get_data_domain + + implicit none + + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: layout(2) !< Layout + integer :: io_layout(2) !< Io layout + type(domain2d) :: Domain !< 2D domain + integer :: isc, isd !< Starting x compute, data domain index + integer :: iec, ied !< Ending x compute, data domain index + integer :: jsc, jsd !< Starting y compute, data domaine index + integer :: jec, jed !< Ending y compute, data domain index + integer :: nhalox !< Number of halos in x + integer :: nhaloy !< Number of halos in y + real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain + real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain + real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain + real(kind=r8_kind), allocatable :: drmask(:,:,:,:) !< Mask in the data domain + logical, allocatable :: clmask(:,:,:,:) !< Logical mask in the compute domain + logical, allocatable :: dlmask(:,:,:,:) !< Logical mask in the data domain + type(time_type) :: Time !< Time of the simulation + type(time_type) :: Time_step !< Time of the simulation + integer :: ntimes !< Number of times + integer :: id_x !< axis id for the x dimension + integer :: id_y !< axis id for the y dimension + integer :: id_z !< axis id for the z dimension + integer :: id_w !< axis id for the w dimension + integer :: id_var0 !< diag_field id for 0d var + integer :: id_var1 !< diag_field id for 1d var + integer :: id_var2 !< diag_field id for 2d var + integer :: id_var3 !< diag_field id for 3d var + integer :: id_var4 !< diag_field id for 4d var + integer :: io_status !< Status after reading the namelist + type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type + logical :: message !< Flag for outputting debug message + integer :: isd1 !< Starting x data domain index (1-based) + integer :: ied1 !< Ending x data domain index (1-based) + integer :: jsd1 !< Starting y data domain index (1-based) + integer :: jed1 !< Ending y data domain index (1-based) + integer :: isw !< Starting index for each thread in the x direction + integer :: iew !< Ending index for each thread in the x direction + integer :: jsw !< Starting index for each thread in the y direction + integer :: jew !< Ending index for each thread in the y direction + integer :: is1 !< Starting index for each thread in the x direction (1-based) + integer :: ie1 !< Ending index for each thread in the x direction (1-based) + integer :: js1 !< Starting index for each thread in the y direction (1-based) + integer :: je1 !< Ending index for each thread in the y direction (1-based) + integer :: iblock !< For looping through the blocks + integer :: i !< For do loops + logical :: used !< Dummy argument to send_data + real(kind=r8_kind) :: missing_value !< Missing value to use + + !< Configuration parameters + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init + call set_calendar_type(JULIAN) + call diag_manager_init + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml') + + Time = set_date(2,1,1,0,0,0) + Time_step = set_time (3600,0) !< 1 hour + nx = 96 + ny = 96 + nz = 5 + nw = 2 + layout = (/1, mpp_npes()/) + io_layout = (/1, 1/) + nhalox = 2 + nhaloy = 2 + ntimes = 48 + + !< Create a lat/lon domain + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy) + call mpp_define_io_domain(Domain, io_layout) + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd, ied, jsd, jed) + + cdata = allocate_buffer(isc, iec, jsc, jec, nz, nw) + call init_buffer(cdata, isc, iec, jsc, jec, 0) + + select case (test_case) + case (test_normal) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the normal send_data calls" + case (test_halos) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with halos" + ddata = allocate_buffer(isd, ied, jsd, jed, nz, nw) + call init_buffer(ddata, isc, iec, jsc, jec, 2) !< The halos never get set + case (test_openmp) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with openmp blocks" + call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, & + nx_block=1, ny_block=4, message=message) + end select + + select case (mask_case) + case (logical_mask) + clmask = allocate_logical_mask(isc, iec, jsc, jec, nz, nw) + if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, :) = .False. + + if (test_case .eq. test_halos) then + dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw) + if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, :) = .False. + endif + case (real_mask) + crmask = allocate_real_mask(isc, iec, jsc, jec, nz, nw) + if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, :) = 0_r8_kind + + if (test_case .eq. test_halos) then + drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw) + if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, :) = 0_r8_kind + endif + end select + + !< Register the axis + id_x = diag_axis_init('x', real((/ (i, i = 1,nx) /), kind=r8_kind), 'point_E', 'x', long_name='point_E', & + Domain2=Domain) + id_y = diag_axis_init('y', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N', 'y', long_name='point_N', & + Domain2=Domain) + id_z = diag_axis_init('z', real((/ (i, i = 1,nz) /), kind=r8_kind), 'point_Z', 'z', long_name='point_Z') + id_w = diag_axis_init('w', real((/ (i, i = 1,nw) /), kind=r8_kind), 'point_W', 'n', long_name='point_W') + + missing_value = -666._r8_kind + !< Register the fields + id_var0 = register_diag_field ('ocn_mod', 'var0', Time, 'Var0d', & + 'mullions', missing_value = missing_value) + id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var1d', & + 'mullions', missing_value = missing_value) + id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var2d', & + 'mullions', missing_value = missing_value) + id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'Var3d', & + 'mullions', missing_value = missing_value) + id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'Var4d', & + 'mullions', missing_value = missing_value) + + !< Get the data domain indices (1 based) + isd1 = isc-isd+1 + jsd1 = jsc-jsd+1 + ied1 = isd1 + iec-isc + jed1 = jsd1 + jec-jsc + + call diag_manager_set_time_end(set_date(2,1,3,0,0,0)) + do i = 1, ntimes + Time = Time + Time_step + + call set_buffer(cdata, i) + used = send_data(id_var0, cdata(1,1,1,1), Time) + + select case(test_case) + case (test_normal) + select case (mask_case) + case (no_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time) + used = send_data(id_var2, cdata(:,:,1,1), Time) + used = send_data(id_var3, cdata(:,:,:,1), Time) + used = send_data(id_var4, cdata(:,:,:,:), Time) + case (real_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, rmask=crmask(:,1,1,1)) + used = send_data(id_var2, cdata(:,:,1,1), Time, rmask=crmask(:,:,1,1)) + used = send_data(id_var3, cdata(:,:,:,1), Time, rmask=crmask(:,:,:,1)) + used = send_data(id_var4, cdata(:,:,:,:), Time, rmask=crmask(:,:,:,:)) + case (logical_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, mask=clmask(:,1,1,1)) + used = send_data(id_var2, cdata(:,:,1,1), Time, mask=clmask(:,:,1,1)) + used = send_data(id_var3, cdata(:,:,:,1), Time, mask=clmask(:,:,:,1)) + used = send_data(id_var4, cdata(:,:,:,:), Time, mask=clmask(:,:,:,:)) + end select + case (test_halos) + call set_buffer(ddata, i) + select case (mask_case) + case (no_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1) + used = send_data(id_var4, ddata(:,:,:,:), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1) + case (real_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, & + rmask=crmask(:,1,1,1)) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + rmask=drmask(:,:,1,1)) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + rmask=drmask(:,:,:,1)) + used = send_data(id_var4, ddata(:,:,:,:), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + rmask=drmask(:,:,:,:)) + case (logical_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, & + mask=clmask(:,1,1,1)) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + mask=dlmask(:,:,1,1)) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + mask=dlmask(:,:,:,1)) + used = send_data(id_var4, ddata(:,:,:,:), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + mask=dlmask(:,:,:,:)) + end select + case (test_openmp) + select case(mask_case) + case (no_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time) + case (logical_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time, & + mask=clmask(:, 1, 1, 1)) + case (real_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time, & + rmask=crmask(:, 1, 1, 1)) + end select +!$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1) + do iblock=1, 4 + isw = my_block%ibs(iblock) + jsw = my_block%jbs(iblock) + iew = my_block%ibe(iblock) + jew = my_block%jbe(iblock) + + !--- indices for 1-based arrays --- + is1 = isw-isc+1 + ie1 = iew-isc+1 + js1 = jsw-jsc+1 + je1 = jew-jsc+1 + + select case (mask_case) + case (no_mask) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1) + used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1) + case (real_mask) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & + rmask=crmask(is1:ie1, js1:je1, 1, 1)) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & + rmask=crmask(is1:ie1, js1:je1, :, 1)) + used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, & + rmask=crmask(is1:ie1, js1:je1, :, :)) + case (logical_mask) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & + mask=clmask(is1:ie1, js1:je1, 1, 1)) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & + mask=clmask(is1:ie1, js1:je1, :, 1)) + used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, & + mask=clmask(is1:ie1, js1:je1, :, :)) + end select + enddo + end select + call diag_send_complete(Time_step) + enddo + + call diag_manager_end(Time) + + call fms_end + + contains + + !> @brief Allocate the logical mask based on the starting/ending indices + !! @return logical mask initiliazed to .True. + function allocate_logical_mask(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + + logical, allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = .True. + end function allocate_logical_mask + + !> @brief Allocate the real mask based on the starting/ending indices + !! @returnreal mask initiliazed to 1_r8_kind + function allocate_real_mask(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + real(kind=r8_kind), allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = 1.0_r8_kind + end function allocate_real_mask + + !> @brief initiliazed the buffer based on the starting/ending indices + subroutine init_buffer(buffer, is, ie, js, je, nhalo) + real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< output buffer + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: nhalo !< Number of halos + + integer :: ii, j, k, l + + do ii = is, ie + do j = js, je + do k = 1, size(buffer, 3) + do l = 1, size(buffer,4) + buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + & + real(j, kind=r8_kind)* 10_r8_kind + & + real(k, kind=r8_kind) + enddo + enddo + enddo + enddo + + end subroutine init_buffer + + !> @brief Set the buffer based on the time_index + subroutine set_buffer(buffer, time_index) + real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< Output buffer + integer, intent(in) :: time_index !< Time index + + buffer = nint(buffer) + real(time_index, kind=r8_kind)/100_r8_kind + + end subroutine set_buffer + +end program test_reduction_methods diff --git a/test_fms/diag_manager/test_time_max.sh b/test_fms/diag_manager/test_time_max.sh new file mode 100755 index 0000000000..d2a0fd7cdc --- /dev/null +++ b/test_fms/diag_manager/test_time_max.sh @@ -0,0 +1,174 @@ +#!/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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true. +cat <<_EOF > diag_table.yaml +title: test_max +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_max + time_units: hours + unlimdim: time + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var0 + output_name: var0_max + reduction: max + kind: r4 + - module: ocn_mod + var_name: var1 + output_name: var1_max + reduction: max + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: var2_max + reduction: max + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_max + reduction: max + kind: r4 + - module: ocn_mod + var_name: var4 + output_name: var4_max + reduction: max + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_Z_max + reduction: max + zbounds: 2. 3. + kind: r4 +- file_name: test_max_regional + time_units: hours + unlimdim: time + sub_region: + - grid_type: latlon + corner1: 78. 78. + corner2: 78. 78. + corner3: 81. 81. + corner4: 81. 81. + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var3 + output_name: var3_max + reduction: max + zbounds: 2. 3. + kind: r4 +_EOF + +my_test_count=1 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' +fi +test_done \ No newline at end of file diff --git a/test_fms/diag_manager/test_time_min.sh b/test_fms/diag_manager/test_time_min.sh new file mode 100755 index 0000000000..f2969d47c9 --- /dev/null +++ b/test_fms/diag_manager/test_time_min.sh @@ -0,0 +1,174 @@ +#!/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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true. +cat <<_EOF > diag_table.yaml +title: test_min +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_min + time_units: hours + unlimdim: time + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var0 + output_name: var0_min + reduction: min + kind: r4 + - module: ocn_mod + var_name: var1 + output_name: var1_min + reduction: min + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: var2_min + reduction: min + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_min + reduction: min + kind: r4 + - module: ocn_mod + var_name: var4 + output_name: var4_min + reduction: min + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_Z_min + reduction: min + zbounds: 2. 3. + kind: r4 +- file_name: test_min_regional + time_units: hours + unlimdim: time + sub_region: + - grid_type: latlon + corner1: 78. 78. + corner2: 78. 78. + corner3: 81. 81. + corner4: 81. 81. + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var3 + output_name: var3_min + reduction: min + zbounds: 2. 3. + kind: r4 +_EOF + +my_test_count=1 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' +fi +test_done \ No newline at end of file diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh new file mode 100755 index 0000000000..9840e0c0ac --- /dev/null +++ b/test_fms/diag_manager/test_time_none.sh @@ -0,0 +1,173 @@ +#!/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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +cat <<_EOF > diag_table.yaml +title: test_none +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_none + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var0 + output_name: var0_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var1 + output_name: var1_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: var2_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var4 + output_name: var4_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_Z + reduction: none + zbounds: 2. 3. + kind: r4 +- file_name: test_none_regional + freq: 6 hours + time_units: hours + unlimdim: time + sub_region: + - grid_type: latlon + corner1: 78. 78. + corner2: 78. 78. + corner3: 81. 81. + corner4: 81. 81. + varlist: + - module: ocn_mod + var_name: var3 + output_name: var3_none + reduction: none + zbounds: 2. 3. + kind: r4 +_EOF + +my_test_count=1 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' +fi +test_done diff --git a/test_fms/diag_manager/test_time_sum.sh b/test_fms/diag_manager/test_time_sum.sh new file mode 100755 index 0000000000..c7631217a4 --- /dev/null +++ b/test_fms/diag_manager/test_time_sum.sh @@ -0,0 +1,171 @@ +#!/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 . +#*********************************************************************** + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +cat <<_EOF > diag_table.yaml +title: test_sum +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_sum + time_units: hours + unlimdim: time + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var0 + output_name: var0_sum + reduction: sum + kind: r4 + - module: ocn_mod + var_name: var1 + output_name: var1_sum + reduction: sum + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: var2_sum + reduction: sum + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_sum + reduction: sum + kind: r4 + - module: ocn_mod + var_name: var4 + output_name: var4_sum + reduction: sum + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_Z + reduction: sum + zbounds: 2. 3. + kind: r4 +- file_name: test_sum_regional + time_units: hours + unlimdim: time + sub_region: + - grid_type: latlon + corner1: 78. 78. + corner2: 78. 78. + corner3: 81. 81. + corner4: 81. 81. + freq: 6 hours + varlist: + - module: ocn_mod + var_name: var3 + output_name: var3_sum + reduction: sum + zbounds: 2. 3. + kind: r4 +_EOF + +my_test_count=1 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +export OMP_NUM_THREADS=1 +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' +export OMP_NUM_THREADS=2 + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +my_test_count=`expr $my_test_count + 1` +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "sum" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' +fi +test_done diff --git a/test_fms/diag_manager/testing_utils.F90 b/test_fms/diag_manager/testing_utils.F90 new file mode 100644 index 0000000000..45530fcc3e --- /dev/null +++ b/test_fms/diag_manager/testing_utils.F90 @@ -0,0 +1,53 @@ +!*********************************************************************** +!* 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 Utilities used in multiple test +module testing_utils + use platform_mod, only: r8_kind + private + + public :: allocate_buffer + public :: test_normal, test_openmp, test_halos + public :: no_mask, logical_mask, real_mask + + integer, parameter :: test_normal = 0 !< sending a buffer in the compute domain + integer, parameter :: test_openmp = 1 !< sending a buffer in the compute domain but with blocking + integer, parameter :: test_halos = 2 !< sending a buffer in the data domain (i.e with halos) + integer, parameter :: no_mask = 0 !< Not using a mask + integer, parameter :: logical_mask = 1 !< Using a logical mask + integer, parameter :: real_mask = 2 !< Using a real mask + + contains + + !> @brief Allocate the output buffer based on the starting/ending indices + !! @return output buffer set to -999_r8_kind + function allocate_buffer(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + real(kind=r8_kind), allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = -999_r8_kind + end function allocate_buffer +end module diff --git a/test_fms/field_manager/Makefile.am b/test_fms/field_manager/Makefile.am index 3353580ff0..01f10ed0dd 100644 --- a/test_fms/field_manager/Makefile.am +++ b/test_fms/field_manager/Makefile.am @@ -39,7 +39,7 @@ test_field_table_read_SOURCES = test_field_table_read.F90 test_field_manager_r4_CPPFLAGS=-DTEST_FM_KIND_=4 -I$(MODDIR) test_field_manager_r8_CPPFLAGS=-DTEST_FM_KIND_=8 -I$(MODDIR) -if SKIP_PARSER_TESTS +if USING_YAML skipflag="skip" else skipflag="" diff --git a/test_fms/field_manager/test_field_manager2.sh b/test_fms/field_manager/test_field_manager2.sh index a320afcf9a..d3a165b164 100755 --- a/test_fms/field_manager/test_field_manager2.sh +++ b/test_fms/field_manager/test_field_manager2.sh @@ -100,7 +100,7 @@ cat <<_EOF > input.nml / _EOF -if [ ! -z $parser_skip ]; then +if [ ! $parser_skip ]; then test_expect_failure "field table read with use_field_table.yaml = .true. but not compiling with yaml" 'mpirun -n 1 ./test_field_table_read' else test_expect_success "field table read with use_field_table.yaml = .true." 'mpirun -n 1 ./test_field_table_read' diff --git a/test_fms/parser/Makefile.am b/test_fms/parser/Makefile.am index 05fbcd737c..ae8c282b99 100644 --- a/test_fms/parser/Makefile.am +++ b/test_fms/parser/Makefile.am @@ -49,10 +49,10 @@ TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh -if SKIP_PARSER_TESTS -skipflag="skip" -else +if USING_YAML skipflag="" +else +skipflag="skip" endif TESTS_ENVIRONMENT = parser_skip=${skipflag} diff --git a/test_fms/tracer_manager/Makefile.am b/test_fms/tracer_manager/Makefile.am index f2a020b6fa..747151344e 100644 --- a/test_fms/tracer_manager/Makefile.am +++ b/test_fms/tracer_manager/Makefile.am @@ -38,7 +38,7 @@ test_tracer_manager_r8_SOURCES = test_tracer_manager.F90 test_tracer_manager_r4_CPPFLAGS=-DTEST_TM_KIND_=4 -I$(MODDIR) test_tracer_manager_r8_CPPFLAGS=-DTEST_TM_KIND_=8 -I$(MODDIR) -if SKIP_PARSER_TESTS +if USING_YAML skipflag="skip" else skipflag="" diff --git a/test_fms/tracer_manager/test_tracer_manager2.sh b/test_fms/tracer_manager/test_tracer_manager2.sh index 2afc300b91..b35122fa3d 100755 --- a/test_fms/tracer_manager/test_tracer_manager2.sh +++ b/test_fms/tracer_manager/test_tracer_manager2.sh @@ -58,7 +58,7 @@ _EOF test_expect_success "tracer_manager r4 with the legacy field table" 'mpirun -n 2 ./test_tracer_manager_r4' test_expect_success "tracer_manager r8 with the legacy field table" 'mpirun -n 2 ./test_tracer_manager_r8' -if [ -z $parser_skip ]; then +if [ $parser_skip ]; then rm -rf field_table cat <<_EOF > input.nml &field_manager_nml