diff --git a/Makefile.am b/Makefile.am index 5f414d574..9254d916e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -42,6 +42,7 @@ SUBDIRS = \ fms2_io \ mosaic2 \ fms \ + parser \ affinity \ mosaic \ time_manager \ diff --git a/configure.ac b/configure.ac index b340c7251..2ec32cd80 100644 --- a/configure.ac +++ b/configure.ac @@ -67,6 +67,12 @@ AC_ARG_WITH([mpi], AS_IF([test ${with_mpi:-yes} = yes], [with_mpi=yes], [with_mpi=no]) +AC_ARG_WITH([yaml], + [AS_HELP_STRING([--with-yaml], + [Build with YAML support. This option will be ignored if --disable-fortran-flag-setting is also given. (Default no)])]) +AS_IF([test ${with_yaml:-no} = no], + [with_yaml=no], + [with_yaml=yes]) AC_ARG_ENABLE([setting-flags], [AS_HELP_STRING([--enable-setting-flags], [Allow configure to set some compiler flags. Disabling this will also disable any other --with or --enable options that set flags, and will only use user-provided falgs. (Default yes)])]) @@ -122,6 +128,19 @@ if test $with_mpi = yes; then AC_CHECK_FUNC([MPI_Init], [], [AC_MSG_ERROR([Can't find the MPI C library. Set CC/LDFLAGS/LIBS])]) fi +# Require yaml +if test $with_yaml = yes; then + AC_CHECK_HEADERS([yaml.h], [], [AC_MSG_ERROR(["Can't find the libYAML C header file. Set CC/CPPFLAGS/CFLAGS"])]) + AC_SEARCH_LIBS([yaml_parser_initialize], [yaml], [], [AC_MSG_ERROR(["Can't find the libYAML C library. Set CC/LDFLAGS/LIBS"])]) + + #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 ) +else + AM_CONDITIONAL([SKIP_PARSER_TESTS], true ) +fi + # Require netCDF AC_CHECK_HEADERS([netcdf.h], [], [AC_MSG_ERROR([Can't find the netCDF C header file. Set CPPFLAGS/CFLAGS])]) AC_SEARCH_LIBS([nc_create], [netcdf], [], [AC_MSG_ERROR([Can't find the netCDF C library. Set LDFLAGS/LIBS])]) @@ -337,6 +356,7 @@ AC_CONFIG_FILES([ random_numbers/Makefile libFMS/Makefile docs/Makefile + parser/Makefile test_fms/test_common.sh test_fms/Makefile test_fms/diag_manager/Makefile @@ -357,6 +377,7 @@ AC_CONFIG_FILES([ test_fms/mosaic/Makefile test_fms/affinity/Makefile test_fms/coupler/Makefile + test_fms/parser/Makefile FMS.pc ]) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 013897aec..e6f9dcd57 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -40,6 +40,7 @@ !> @brief File for @ref data_override_mod module data_override_mod +use yaml_parser_mod use constants_mod, only: PI use mpp_mod, only : mpp_error, FATAL, WARNING, stdout, stdlog, mpp_max use mpp_mod, only : input_nml_file @@ -139,7 +140,12 @@ module data_override_mod real :: min_glo_lon_lnd, max_glo_lon_lnd real :: min_glo_lon_ice, max_glo_lon_ice integer:: num_fields = 0 !< number of fields in override_array already processed +#ifdef use_yaml +type(data_type), dimension(:), allocatable :: data_table !< user-provided data table +#else type(data_type), dimension(max_table) :: data_table !< user-provided data table +#endif + type(data_type) :: default_table type(override_type), dimension(max_array), save :: override_array !< to store processed fields type(override_type), save :: default_array @@ -188,15 +194,10 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan character(len=128) :: grid_file = 'INPUT/grid_spec.nc' integer :: is,ie,js,je,use_get_grid_version - integer :: i, iunit, ntable, ntable_lima, ntable_new, unit,io_status, ierr - character(len=256) :: record + integer :: i, unit, io_status, ierr logical :: file_open - logical :: ongrid - character(len=128) :: region, region_type type(FmsNetcdfFile_t) :: fileobj - type(data_type) :: data_entry - debug_data_override = .false. read (input_nml_file, data_override_nml, iostat=io_status) @@ -235,9 +236,133 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan default_table%file_name = 'none' default_table%factor = 1. default_table%interpol_method = 'bilinear' + +#ifdef use_yaml + call read_table_yaml(data_table) +#else do i = 1,max_table data_table(i) = default_table enddo + call read_table(data_table) +#endif + +! Initialize override array + default_array%gridname = 'NONE' + default_array%fieldname = 'NONE' + default_array%t_index = -1 + default_array%dims = -1 + default_array%comp_domain = -1 + do i = 1, max_array + override_array(i) = default_array + enddo + call time_interp_external_init + end if + + module_is_initialized = .TRUE. + + if ( .NOT. (atm_on .or. ocn_on .or. lnd_on .or. ice_on .or. lndUG_on)) return + call fms2_io_init + +! Test if grid_file is already opened + inquire (file=trim(grid_file), opened=file_open) + if(file_open) call mpp_error(FATAL, trim(grid_file)//' already opened') + + if(.not. open_file(fileobj, grid_file, 'read' )) then + call mpp_error(FATAL, 'data_override_mod: Error in opening file '//trim(grid_file)) + endif + + if(variable_exists(fileobj, "x_T" ) .OR. variable_exists(fileobj, "geolon_t" ) ) then + use_get_grid_version = 1 + call close_file(fileobj) + else if(variable_exists(fileobj, "ocn_mosaic_file" ) .OR. variable_exists(fileobj, "gridfiles" ) ) then + use_get_grid_version = 2 + if(variable_exists(fileobj, "gridfiles" ) ) then + if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' // & + 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true') + end if + else + call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file)) + endif + + if(use_get_grid_version .EQ. 1) then + if (atm_on .and. .not. allocated(lon_local_atm) ) then + call mpp_get_compute_domain( atm_domain,is,ie,js,je) + allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) + call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & + min_glo_lon_atm, max_glo_lon_atm, grid_center_bug ) + endif + if (ocn_on .and. .not. allocated(lon_local_ocn) ) then + call mpp_get_compute_domain( ocn_domain,is,ie,js,je) + allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) + call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & + min_glo_lon_ocn, max_glo_lon_ocn, grid_center_bug ) + endif + + if (lnd_on .and. .not. allocated(lon_local_lnd) ) then + call mpp_get_compute_domain( lnd_domain,is,ie,js,je) + allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) + call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & + min_glo_lon_lnd, max_glo_lon_lnd, grid_center_bug ) + endif + + if (ice_on .and. .not. allocated(lon_local_ice) ) then + call mpp_get_compute_domain( ice_domain,is,ie,js,je) + allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) + call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & + min_glo_lon_ice, max_glo_lon_ice, grid_center_bug ) + endif + else + if (atm_on .and. .not. allocated(lon_local_atm) ) then + call mpp_get_compute_domain(atm_domain,is,ie,js,je) + allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) + call get_grid_version_2(fileobj, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & + min_glo_lon_atm, max_glo_lon_atm ) + endif + + if (ocn_on .and. .not. allocated(lon_local_ocn) ) then + call mpp_get_compute_domain( ocn_domain,is,ie,js,je) + allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) + call get_grid_version_2(fileobj, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & + min_glo_lon_ocn, max_glo_lon_ocn ) + endif + + if (lnd_on .and. .not. allocated(lon_local_lnd) ) then + call mpp_get_compute_domain( lnd_domain,is,ie,js,je) + allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) + call get_grid_version_2(fileobj, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & + min_glo_lon_lnd, max_glo_lon_lnd ) + endif + + if (ice_on .and. .not. allocated(lon_local_ice) ) then + call mpp_get_compute_domain( ice_domain,is,ie,js,je) + allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) + call get_grid_version_2(fileobj, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & + min_glo_lon_ice, max_glo_lon_ice ) + endif + end if + if(use_get_grid_version .EQ. 2) then + call close_file(fileobj) + end if + +end subroutine data_override_init + +#ifndef use_yaml +subroutine read_table(data_table) + type(data_type), dimension(max_table), intent(inout) :: data_table + + integer :: ntable + integer :: ntable_lima + integer :: ntable_new + + integer :: iunit + integer :: io_status + character(len=256) :: record + type(data_type) :: data_entry + + logical :: ongrid + character(len=128) :: region, region_type + + integer :: sunit ! Read coupler_table open(newunit=iunit, file='data_table', action='READ', iostat=io_status) @@ -273,13 +398,13 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan data_entry%interpol_method == 'bicubic' .or. & data_entry%interpol_method == 'bilinear' .or. & data_entry%interpol_method == 'none')) then - unit = stdout() - write(unit,*)" gridname is ", trim(data_entry%gridname) - write(unit,*)" fieldname_code is ", trim(data_entry%fieldname_code) - write(unit,*)" fieldname_file is ", trim(data_entry%fieldname_file) - write(unit,*)" file_name is ", trim(data_entry%file_name) - write(unit,*)" factor is ", data_entry%factor - write(unit,*)" interpol_method is ", trim(data_entry%interpol_method) + sunit = stdout() + write(sunit,*)" gridname is ", trim(data_entry%gridname) + write(sunit,*)" fieldname_code is ", trim(data_entry%fieldname_code) + write(sunit,*)" fieldname_file is ", trim(data_entry%fieldname_file) + write(sunit,*)" file_name is ", trim(data_entry%file_name) + write(sunit,*)" factor is ", data_entry%factor + write(sunit,*)" interpol_method is ", trim(data_entry%interpol_method) call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' & //'its value should be "default", "bicubic", "bilinear" or "none" ') endif @@ -328,13 +453,13 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan data_entry%interpol_method == 'bicubic' .or. & data_entry%interpol_method == 'bilinear' .or. & data_entry%interpol_method == 'none')) then - unit = stdout() - write(unit,*)" gridname is ", trim(data_entry%gridname) - write(unit,*)" fieldname_code is ", trim(data_entry%fieldname_code) - write(unit,*)" fieldname_file is ", trim(data_entry%fieldname_file) - write(unit,*)" file_name is ", trim(data_entry%file_name) - write(unit,*)" factor is ", data_entry%factor - write(unit,*)" interpol_method is ", trim(data_entry%interpol_method) + sunit = stdout() + write(sunit,*)" gridname is ", trim(data_entry%gridname) + write(sunit,*)" fieldname_code is ", trim(data_entry%fieldname_code) + write(sunit,*)" fieldname_file is ", trim(data_entry%fieldname_file) + write(sunit,*)" file_name is ", trim(data_entry%file_name) + write(sunit,*)" factor is ", data_entry%factor + write(sunit,*)" interpol_method is ", trim(data_entry%interpol_method) call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' & //'its value should be "default", "bicubic", "bilinear" or "none" ') endif @@ -354,106 +479,51 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan 'data_override_mod: New and old formats together in same data_table not supported') close(iunit, iostat=io_status) if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in closing file data_table') +end subroutine read_table + +#else +subroutine read_table_yaml(data_table) + type(data_type), dimension(:), allocatable, intent(out) :: data_table + + integer, allocatable :: entry_id(:) + integer :: nentries + integer :: i + character(len=50) :: buffer + integer :: file_id + + file_id = open_and_parse_file("data_table.yaml") + nentries = get_num_blocks(file_id, "data_table") + allocate(data_table(nentries)) + allocate(entry_id(nentries)) + call get_block_ids(file_id, "data_table", entry_id) + + do i = 1, nentries + call get_value_from_key(file_id, entry_id(i), "gridname", data_table(i)%gridname) + call get_value_from_key(file_id, entry_id(i), "fieldname_code", data_table(i)%fieldname_code) + call get_value_from_key(file_id, entry_id(i), "fieldname_file", data_table(i)%fieldname_file) + call get_value_from_key(file_id, entry_id(i), "file_name", data_table(i)%file_name) + call get_value_from_key(file_id, entry_id(i), "interpol_method", data_table(i)%interpol_method) + call get_value_from_key(file_id, entry_id(i), "factor", data_table(i)%factor) + call get_value_from_key(file_id, entry_id(i), "region_type", buffer, is_optional=.true.) + + if(trim(buffer) == "inside_region" ) then + data_table(i)%region_type = INSIDE_REGION + else if( trim(buffer) == "outside_region" ) then + data_table(i)%region_type = OUTSIDE_REGION + else + data_table(i)%region_type = NO_REGION + endif -! Initialize override array - default_array%gridname = 'NONE' - default_array%fieldname = 'NONE' - default_array%t_index = -1 - default_array%dims = -1 - default_array%comp_domain = -1 - do i = 1, max_array - override_array(i) = default_array - enddo - call time_interp_external_init - end if - - module_is_initialized = .TRUE. - - if ( .NOT. (atm_on .or. ocn_on .or. lnd_on .or. ice_on .or. lndUG_on)) return - call fms2_io_init - -! Test if grid_file is already opened - inquire (file=trim(grid_file), opened=file_open) - if(file_open) call mpp_error(FATAL, trim(grid_file)//' already opened') - - if(.not. open_file(fileobj, grid_file, 'read' )) then - call mpp_error(FATAL, 'data_override_mod: Error in opening file '//trim(grid_file)) - endif - - if(variable_exists(fileobj, "x_T" ) .OR. variable_exists(fileobj, "geolon_t" ) ) then - use_get_grid_version = 1 - call close_file(fileobj) - else if(variable_exists(fileobj, "ocn_mosaic_file" ) .OR. variable_exists(fileobj, "gridfiles" ) ) then - use_get_grid_version = 2 - if(variable_exists(fileobj, "gridfiles" ) ) then - if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' // & - 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true') - end if - else - call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file)) - endif - - if(use_get_grid_version .EQ. 1) then - if (atm_on .and. .not. allocated(lon_local_atm) ) then - call mpp_get_compute_domain( atm_domain,is,ie,js,je) - allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) - call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & - min_glo_lon_atm, max_glo_lon_atm, grid_center_bug ) - endif - if (ocn_on .and. .not. allocated(lon_local_ocn) ) then - call mpp_get_compute_domain( ocn_domain,is,ie,js,je) - allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) - call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & - min_glo_lon_ocn, max_glo_lon_ocn, grid_center_bug ) - endif - - if (lnd_on .and. .not. allocated(lon_local_lnd) ) then - call mpp_get_compute_domain( lnd_domain,is,ie,js,je) - allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) - call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & - min_glo_lon_lnd, max_glo_lon_lnd, grid_center_bug ) - endif - - if (ice_on .and. .not. allocated(lon_local_ice) ) then - call mpp_get_compute_domain( ice_domain,is,ie,js,je) - allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) - call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & - min_glo_lon_ice, max_glo_lon_ice, grid_center_bug ) - endif - else - if (atm_on .and. .not. allocated(lon_local_atm) ) then - call mpp_get_compute_domain(atm_domain,is,ie,js,je) - allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) - call get_grid_version_2(fileobj, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & - min_glo_lon_atm, max_glo_lon_atm ) - endif - - if (ocn_on .and. .not. allocated(lon_local_ocn) ) then - call mpp_get_compute_domain( ocn_domain,is,ie,js,je) - allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) - call get_grid_version_2(fileobj, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & - min_glo_lon_ocn, max_glo_lon_ocn ) - endif - - if (lnd_on .and. .not. allocated(lon_local_lnd) ) then - call mpp_get_compute_domain( lnd_domain,is,ie,js,je) - allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) - call get_grid_version_2(fileobj, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & - min_glo_lon_lnd, max_glo_lon_lnd ) - endif + call get_value_from_key(file_id, entry_id(i), "lon_start", data_table(i)%lon_start, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lon_end", data_table(i)%lon_end, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lat_start", data_table(i)%lat_start, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lat_end", data_table(i)%lat_end, is_optional=.true.) - if (ice_on .and. .not. allocated(lon_local_ice) ) then - call mpp_get_compute_domain( ice_domain,is,ie,js,je) - allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) - call get_grid_version_2(fileobj, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & - min_glo_lon_ice, max_glo_lon_ice ) - endif - end if - if(use_get_grid_version .EQ. 2) then - call close_file(fileobj) - end if + end do -end subroutine data_override_init + table_size = nentries !< Because one variable is not enough +end subroutine read_table_yaml +#endif !> @brief Unset domains that had previously been set for use by data_override. !! diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 0cc043b0e..deb1eb39b 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -53,7 +53,6 @@ MODULE diag_data_mod USE time_manager_mod, ONLY: time_type USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG - USE mpp_io_mod, ONLY: fieldtype USE fms_mod, ONLY: WARNING, write_version_number #ifdef use_netCDF ! NF90_FILL_REAL has value of 9.9692099683868690e+36. @@ -148,12 +147,12 @@ MODULE diag_data_mod !> @brief Diagnostic field type !> @ingroup diag_data_mod TYPE diag_fieldtype - TYPE(fieldtype) :: Field TYPE(domain2d) :: Domain TYPE(domainUG) :: DomainU REAL :: miss, miss_pack LOGICAL :: miss_present, miss_pack_present INTEGER :: tile_count + character(len=128) :: fieldname !< Fieldname END TYPE diag_fieldtype !> @brief Attribute type for diagnostic fields diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 3d9ba7a92..8a8c2cf96 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -195,13 +195,12 @@ MODULE diag_manager_mod 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 - USE mpp_io_mod, ONLY: mpp_open, mpp_close, mpp_get_maxunits 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 fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,& - & file_exist, fms_error_handler, check_nml_error, get_mosaic_tile_file, lowercase + & fms_error_handler, check_nml_error, lowercase USE fms_io_mod, ONLY: get_instance_filename USE diag_axis_mod, ONLY: diag_axis_init, get_axis_length, get_axis_num, get_domain2d, get_tile_count,& & diag_axis_add_attribute, axis_compatible_check, CENTER, NORTH, EAST @@ -3462,7 +3461,7 @@ SUBROUTINE diag_manager_end(time) INTEGER :: file IF ( do_diag_field_log ) THEN - CALL mpp_close (diag_log_unit) + close (diag_log_unit) END IF DO file = 1, num_files CALL closing_file(file, time) @@ -3632,16 +3631,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) CALL error_mesg('diag_manager_mod::diag_manager_init', 'Using CMOR missing value ('//TRIM(err_msg_local)//').', NOTE) END IF - ! Issue note if attempting to set diag_manager_nml::max_files larger than - ! mpp_get_maxunits() -- Default is 1024 set in mpp_io.F90 - IF ( max_files .GT. mpp_get_maxunits() ) THEN - err_msg_local = '' - WRITE (err_msg_local,'(A,I6,A,I6,A,I6,A)') "DIAG_MANAGER_NML variable 'max_files' (",max_files,") is larger than '",& - & mpp_get_maxunits(),"'. Forcing 'max_files' to be ",mpp_get_maxunits(),"." - CALL error_mesg('diag_manager_mod::diag_managet_init', TRIM(err_msg_local), NOTE) - max_files = mpp_get_maxunits() - END IF - ! How to handle Out of Range Warnings. IF ( oor_warnings_fatal ) THEN oor_warning = FATAL @@ -3707,7 +3696,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN - CALL mpp_open(diag_log_unit, 'diag_field_log.out', nohdrs=.TRUE.) + open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') WRITE (diag_log_unit,'(777a)') & & 'Module', SEP, 'Field', SEP, 'Long Name', SEP,& & 'Units', SEP, 'Number of Axis', SEP, 'Time Axis', SEP,& diff --git a/diag_manager/diag_output.F90 b/diag_manager/diag_output.F90 index 0913b256a..afcfb5d46 100644 --- a/diag_manager/diag_output.F90 +++ b/diag_manager/diag_output.F90 @@ -34,11 +34,6 @@ MODULE diag_output_mod use,intrinsic :: iso_fortran_env, only: real128 use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & c_int32_t,c_int16_t,c_intptr_t -! use_mpp_io = .false. - USE mpp_io_mod, ONLY: axistype, fieldtype, mpp_io_init, & - & mpp_get_id, MPP_WRONLY, MPP_OVERWR,& - & MPP_NETCDF, MPP_MULTI, MPP_SINGLE, mpp_get_field_name, & - & fillin_fieldtype USE mpp_domains_mod, ONLY: domain1d, domain2d, mpp_define_domains, mpp_get_pelist,& & mpp_get_global_domain, mpp_get_compute_domains, null_domain1d, null_domain2d,& & domainUG, null_domainUG, CENTER, EAST, NORTH, mpp_get_compute_domain,& @@ -62,8 +57,6 @@ MODULE diag_output_mod use mpp_mod, only: mpp_gather use mpp_mod, only: uppercase,lowercase use fms2_io_mod - use axis_utils2_mod, only: axis_edges - IMPLICIT NONE @@ -84,7 +77,6 @@ MODULE diag_output_mod INTEGER :: num_axis_in_file = 0 INTEGER, DIMENSION(max_axis_num) :: axis_in_file LOGICAL, DIMENSION(max_axis_num) :: time_axis_flag, edge_axis_flag - TYPE(axistype), DIMENSION(max_axis_num), SAVE :: Axis_types LOGICAL :: module_is_initialized = .FALSE. @@ -92,143 +84,41 @@ MODULE diag_output_mod character(len=*), parameter :: version = '2020.03' !> @} - !> Write diag field using @ref fms2_io - !> @ingroup diag_output_mod - interface diag_field_write - module procedure diag_field_write_field - module procedure diag_field_write_varname - end interface - - !> Initialize output for writing. - !> @ingroup diag_output_mod - interface diag_output_init - module procedure diag_output_init_fms2_io - end interface - - !> Writes axis metadata to a file. - !> @ingroup diag_output_mod - interface write_axis_meta_data - module procedure write_axis_meta_data_fms2_io - end interface - - !> Writes field metadata to a file. - !> @ingroup diag_output_mod - interface write_field_meta_data - module procedure write_field_meta_data_fms2_io - end interface - - !> Private interface to write metadata for an attribute to a file. - !! - !> @note Added for mpp_io support - !> @ingroup diag_output_mod - interface write_attribute_meta - module procedure write_attribute_meta_fms2_io - end interface - !> @addtogroup diag_output_mod !> @{ CONTAINS - !> @brief Registers the time axis and opens the output file. - SUBROUTINE diag_output_init_fms2_io (file_name, FORMAT, file_title, file_unit,& - & all_scalar_or_1d, domain, domainU, fileobj, fileobjU, fileobjND, fnum_domain, & + !> @brief Opens the output file. + SUBROUTINE diag_output_init (file_name, file_title, file_unit,& + & domain, domainU, fileobj, fileobjU, fileobjND, fnum_domain, & & attributes) - CHARACTER(len=*), INTENT(in) :: file_name !< Output file name + CHARACTER(len=*), INTENT(in) :: file_name !< Output file name CHARACTER(len=*), INTENT(in) :: file_title !< Descriptive title for the file - INTEGER , INTENT(in) :: FORMAT !< File format (Currently only 'NETCDF' is valid) - INTEGER , INTENT(out) :: file_unit !< File unit number assigned to the output file. - !! Needed for subsuquent calls to - !! diag_output_mod - LOGICAL , INTENT(in) :: all_scalar_or_1d - TYPE(domain2d) , INTENT(in) :: domain - TYPE(diag_atttype), INTENT(in), DIMENSION(:), OPTIONAL :: attributes - TYPE(domainUG), INTENT(in) :: domainU !< The unstructure domain - type(FmsNetcdfUnstructuredDomainFile_t),intent(inout),target :: fileobjU - type(FmsNetcdfDomainFile_t),intent(inout),target :: fileobj - type(FmsNetcdfFile_t),intent(inout),target :: fileobjND + INTEGER , INTENT(out) :: file_unit !< File unit number assigned to the output file. + !! Needed for subsuquent calls to + !! diag_output_mod + TYPE(domain2d) , INTENT(in) :: domain !< Domain associated with file, if domain decomposed + TYPE(domainUG) , INTENT(in) :: domainU !< The unstructure domain + type(FmsNetcdfDomainFile_t),intent(inout),target :: fileobj !< Domain decomposed fileobj + type(FmsNetcdfUnstructuredDomainFile_t),intent(inout),target :: fileobjU !< Unstructured domain fileobj + type(FmsNetcdfFile_t),intent(inout),target :: fileobjND !< Non domain decomposed fileobj + character(*),intent(out) :: fnum_domain !< String indicating the type of fileobj was used: + !! "2d" domain decomposed + !! "ug" unstrucuted domain decomposed + !! "nd" no domain + TYPE(diag_atttype), INTENT(in), OPTIONAL :: attributes(:) !< Array of global attributes to be written to file + class(FmsNetcdfFile_t), pointer :: fileob => NULL() - character(*),intent(out) :: fnum_domain - INTEGER :: form, threading, fileset, i + integer :: i !< For looping through number of attributes TYPE(diag_global_att_type) :: gAtt - character(len=:),allocatable :: fname_no_tile - integer :: len_file_name integer, allocatable, dimension(:) :: current_pelist integer :: mype !< The pe you are on character(len=9) :: mype_string !< a string to store the pe !---- initialize mpp_io ---- IF ( .NOT.module_is_initialized ) THEN - CALL mpp_io_init () module_is_initialized = .TRUE. CALL write_version_number("DIAG_OUTPUT_MOD", version) END IF - !---- set up output file ---- - SELECT CASE (FORMAT) - CASE (NETCDF1) - form = MPP_NETCDF - threading = MPP_MULTI - fileset = MPP_MULTI - CASE default - ! invalid format - CALL error_mesg('diag_output_init', 'invalid format', FATAL) - END SELECT - - IF(all_scalar_or_1d) THEN - threading = MPP_SINGLE - fileset = MPP_SINGLE - END IF - - len_file_name = len(trim(file_name)) -!> If the file name has .tileX or .tileX.nc where X is a one or two digit tile number, removes -!! that suffix from the time name because fms2_io will add it -!! \note If mpp_domains accepts more than 99 tiles, this will need to be updated - allocate(character(len=len_file_name) :: fname_no_tile) - if (len_file_name < 6) then - if (trim(file_name) == "tile") then - call error_mesg('diag_output_init', 'You can not name your history file "tile"',FATAL) - else - fname_no_tile = trim(file_name) - endif - !> One-digit tile numbers example - !! \verbatim - !! filename.tile1.nc - !! 09876543210 - !! ^ ^ - !! filename.tile1 - !! 09876543210 - !! ^ ^ - !! \endverbatim - elseif (lowercase(file_name(len_file_name-4:len_file_name-1)) .eq. "tile") then - fname_no_tile = file_name(1:len_file_name-6) - elseif (len_file_name < 9) then - fname_no_tile = trim(file_name) - elseif (lowercase(file_name(len_file_name-7:len_file_name-4)) .eq. "tile") then - fname_no_tile = file_name(1:len_file_name-9) - !> Two-digit tile numbers example - !! \verbatim - !! filename.tile10.nc - !! 09876543210 - !! ^ ^ - !! filename.tile10 - !! 09876543210 - !! ^ ^ - !! \endverbatim - elseif (lowercase(file_name(len_file_name-5:len_file_name-2)) .eq. "tile") then - fname_no_tile = file_name(1:len_file_name-7) - - elseif (lowercase(file_name(len_file_name-5:len_file_name-8)) .eq. "tile") then - fname_no_tile = file_name(1:len_file_name-10) - else - fname_no_tile = trim(file_name) - endif -!> If there is a .nc suffix on the file name, removes the .nc - if (len(trim(fname_no_tile)) > 3 ) then - checkNC: do i = 3,len(trim(fname_no_tile)) - if (fname_no_tile(i-2:i) == ".nc") then - fname_no_tile(i-2:i) = " " - exit checkNC - endif - enddo checkNC - endif !> Checks to make sure that only domain2D or domainUG is used. If both are not null, then FATAL if (domain .NE. NULL_DOMAIN2D .AND. domainU .NE. NULL_DOMAINUG)& @@ -240,7 +130,7 @@ SUBROUTINE diag_output_init_fms2_io (file_name, FORMAT, file_title, file_unit,& !> Check if there is an io_domain iF ( associated(mpp_get_io_domain(domain)) ) then fileob => fileobj - if (.not.check_if_open(fileob)) call open_check(open_file(fileobj, trim(fname_no_tile)//".nc", "overwrite", & + if (.not.check_if_open(fileob)) call open_check(open_file(fileobj, trim(file_name)//".nc", "overwrite", & domain, is_restart=.false.)) fnum_domain = "2d" ! 2d domain file_unit = 2 @@ -249,7 +139,7 @@ SUBROUTINE diag_output_init_fms2_io (file_name, FORMAT, file_title, file_unit,& mype = mpp_pe() write(mype_string,'(I0.4)') mype if (.not.check_if_open(fileob)) then - call open_check(open_file(fileobjND, trim(fname_no_tile)//".nc."//trim(mype_string), "overwrite", & + call open_check(open_file(fileobjND, trim(file_name)//".nc."//trim(mype_string), "overwrite", & is_restart=.false.)) !< For regional subaxis add the NumFilesInSet attribute, which is added by fms2_io for (other) !< domains with sufficient decomposition info. Note mppnccombine will work with an entry of zero. @@ -260,17 +150,16 @@ SUBROUTINE diag_output_init_fms2_io (file_name, FORMAT, file_title, file_unit,& endiF ELSE IF (domainU .NE. NULL_DOMAINUG) THEN fileob => fileobjU - if (.not.check_if_open(fileob)) call open_check(open_file(fileobjU, trim(fname_no_tile)//".nc", "overwrite", & + if (.not.check_if_open(fileob)) call open_check(open_file(fileobjU, trim(file_name)//".nc", "overwrite", & domainU, is_restart=.false.)) fnum_domain = "ug" ! unstructured grid file_unit=3 ELSE fileob => fileobjND -! if (.not.check_if_open(fileob) .and. mpp_pe() == mpp_root_pe()) then allocate(current_pelist(mpp_npes())) call mpp_get_current_pelist(current_pelist) if (.not.check_if_open(fileob)) then - call open_check(open_file(fileobjND, trim(fname_no_tile)//".nc", "overwrite", & + call open_check(open_file(fileobjND, trim(file_name)//".nc", "overwrite", & pelist=current_pelist, is_restart=.false.)) endif fnum_domain = "nd" ! no domain @@ -311,18 +200,17 @@ SUBROUTINE diag_output_init_fms2_io (file_name, FORMAT, file_title, file_unit,& call register_global_attribute(fileob, 'grid_tile', TRIM(gAtt%tile_name), str_len=len_trim(gAtt%tile_name)) - END SUBROUTINE diag_output_init_fms2_io + END SUBROUTINE diag_output_init !> @brief Write the axis meta data to file. - SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_axis_registered) + SUBROUTINE write_axis_meta_data(file_unit, axes, fileob, time_ops, time_axis_registered) INTEGER, INTENT(in) :: file_unit !< File unit number INTEGER, INTENT(in) :: axes(:) !< Array of axis ID's, including the time axis - class(FmsNetcdfFile_t) , intent(inout),target :: fileob - class(FmsNetcdfFile_t) ,pointer :: fptr + class(FmsNetcdfFile_t) , intent(inout) :: fileob !< FMS2_io fileobj LOGICAL, INTENT(in), OPTIONAL :: time_ops !< .TRUE. if this file contains any min, max, time_rms, or time_average - logical, intent(inout) , optional :: time_axis_registered - TYPE(domain1d) :: Domain + logical, intent(inout) , optional :: time_axis_registered !< .TRUE. if the time axis was already written to the file + TYPE(domain1d) :: Domain TYPE(domainUG) :: domainU CHARACTER(len=mxch) :: axis_name, axis_units, axis_name_current @@ -330,20 +218,14 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ CHARACTER(len=1) :: axis_cart_name INTEGER :: axis_direction, axis_edges REAL, ALLOCATABLE :: axis_data(:) - INTEGER, ALLOCATABLE :: axis_extent(:), pelist(:) integer :: domain_size, axis_length, axis_pos INTEGER :: num_attributes TYPE(diag_atttype), DIMENSION(:), ALLOCATABLE :: attributes INTEGER :: calendar, id_axis, id_time_axis INTEGER :: i, j, index, num, length, edges_index - INTEGER :: gbegin, gend, gsize, ndivs + INTEGER :: gend !< End index of global io_domain LOGICAL :: time_ops1 CHARACTER(len=2048) :: err_msg - type(domainUG),pointer :: io_domain - integer(I4_KIND) :: io_domain_npes - integer(I4_KIND),dimension(:),allocatable :: io_pelist - integer(I4_KIND),dimension(:),allocatable :: unstruct_axis_sizes - real,dimension(:),allocatable :: unstruct_axis_data integer :: id_axis_current logical :: is_time_axis_registered integer :: istart, iend @@ -355,7 +237,6 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ ! Make sure err_msg is initialized err_msg = '' - fptr => fileob !Use for selecting a type IF ( PRESENT(time_ops) ) THEN time_ops1 = time_ops ELSE @@ -405,242 +286,88 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ & num_attributes, attributes, domain_position=axis_pos) IF ( Domain .NE. null_domain1d ) THEN - IF ( length > 0 ) THEN - if (trim(uppercase(trim(axis_cart_name))) .eq. "X" .or. trim(uppercase(trim(axis_cart_name))) .eq. "Y") then - select type (fptr) - type is (FmsNetcdfDomainFile_t) - call register_axis(fptr, axis_name, lowercase(trim(axis_cart_name)), domain_position=axis_pos ) - if (allocated(fptr%pelist)) then - call get_global_io_domain_indices(fptr, trim(axis_name), istart, iend) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data(istart:iend) ) - endif - type is (FmsNetcdfFile_t) !< For regional X and Y axes, treat as any other axis - call mpp_get_global_domain(domain, begin=gstart, end=gend) !< Get the global indicies - call mpp_get_compute_domain(domain, begin=cstart, end=cend, size=clength) !< Get the compute indicies - iend = cend - gstart + 1 !< Get the array indicies for the axis data - istart = cstart - gstart + 1 - call register_axis(fptr, axis_name, dimension_length=clength) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - !< For regional subaxis add the "domain_decomposition" attribute, which is added - !< fms2_io for (other) domains with sufficient decomposition info. - call register_variable_attribute(fptr, axis_name, "domain_decomposition", & - (/gstart, gend, cstart, cend/)) - call write_data(fptr, axis_name, axis_data(istart:iend) ) - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The file object is not the right type. It must be FmsNetcdfDomainFile_t or "//& - "FmsNetcdfFile_t for a X or Y axis, ", FATAL) - end select - endif + select type (fileob) + type is (FmsNetcdfFile_t) + !> If the axis is domain decomposed and the type is FmsNetcdfFile_t, this is regional diagnostic + !! So treat it as any other dimension + call mpp_get_global_domain(domain, begin=gstart, end=gend) !< Get the global indicies + call mpp_get_compute_domain(domain, begin=cstart, end=cend, size=clength) !< Get the compute indicies + iend = cend - gstart + 1 !< Get the array indicies for the axis data + istart = cstart - gstart + 1 + call register_axis(fileob, axis_name, dimension_length=clength) + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + + !> For regional subaxis add the "domain_decomposition" attribute, which is added + !> fms2_io for (other) domains with sufficient decomposition info. + call register_variable_attribute(fileob, axis_name, "domain_decomposition", & + (/gstart, gend, cstart, cend/)) + type is (FmsNetcdfDomainFile_t) + !> If the axis is domain decomposed and the type is FmsNetcdfDomainFile_t, this is a domain decomposed dimension + !! so register it as one + call register_axis(fileob, axis_name, lowercase(trim(axis_cart_name)), domain_position=axis_pos ) + call get_global_io_domain_indices(fileob, trim(axis_name), istart, iend) + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + end select - ELSE - select type (fptr) - type is (FmsNetcdfDomainFile_t) - call register_axis(fptr, axis_name, lowercase(trim(axis_cart_name)), domain_position=axis_pos ) - if (allocated(fptr%pelist)) then - call get_global_io_domain_indices(fptr, trim(axis_name), istart, iend) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - endif - type is (FmsNetcdfUnstructuredDomainFile_t) - call register_axis(fptr, axis_name ) - type is (FmsNetcdfFile_t) - call register_axis(fptr, axis_name, dimension_length=size(axis_data)) - if (allocated(fptr%pelist)) then -! call get_global_io_domain_indices(fptr, trim(axis_name), istart, iend) - istart = lbound(axis_data,1) - iend = ubound(axis_data,1) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - endif - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The FmsNetcdfDomain file object is not the right type.", FATAL) - end select - call register_field(fileob, axis_name, type_str, (/axis_name/) ) - call register_variable_attribute(fileob, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - call register_variable_attribute(fileob, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fileob, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fileob, axis_name, axis_data(istart:iend) ) - END IF + ELSE IF ( DomainU .NE. null_domainUG) THEN + select type(fileob) + type is (FmsNetcdfUnstructuredDomainFile_t) + !> If the axis is in unstructured domain and the type is FmsNetcdfUnstructuredDomainFile_t, this is an unstrucutred axis + !! so register it as one + call register_axis(fileob, axis_name ) + end select + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + istart = lbound(axis_data,1) + iend = ubound(axis_data,1) ELSE - IF ( length > 0 ) THEN - - !For an unstructured dimension, only the root rank of the io_domain - !pelist will perform the wirte, so a gather of the unstructured - !axis size and axis data is required. - if (uppercase(trim(axis_cart_name)) .eq. "U") then - if (DomainU .eq. null_domainUG) then - call error_mesg("diag_output_mod::write_axis_meta_data", & - "A non-nul domainUG is required to" & - //" write unstructured axis metadata.", & - FATAL) - endif - io_domain => null() - io_domain => mpp_get_UG_io_domain(DomainU) - io_domain_npes = mpp_get_UG_domain_npes(io_domain) - allocate(io_pelist(io_domain_npes)) - call mpp_get_UG_domain_pelist(io_domain, & - io_pelist) - allocate(unstruct_axis_sizes(io_domain_npes)) - unstruct_axis_sizes = 0 - call mpp_gather((/size(axis_data)/), & - unstruct_axis_sizes, & - io_pelist) - if (mpp_pe() .eq. io_pelist(1)) then - allocate(unstruct_axis_data(sum(unstruct_axis_sizes))) - else - allocate(unstruct_axis_data(1)) - endif - unstruct_axis_data = 0.0 - call mpp_gather(axis_data, & - size(axis_data), & - unstruct_axis_data, & - unstruct_axis_sizes, & - io_pelist) - select type (fptr) - type is (FmsNetcdfUnstructuredDomainFile_t) - call register_axis(fptr, axis_name ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - call write_data(fptr, axis_name, axis_data) - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The file unstructred 1 object is not the right type.", NOTE) - end select - deallocate(io_pelist) - deallocate(unstruct_axis_sizes) - deallocate(unstruct_axis_data) - io_domain => null() - - else - select type (fptr) - type is (FmsNetcdfUnstructuredDomainFile_t) - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - type is (FmsNetcdfDomainFile_t) - if (.not.variable_exists(fptr, axis_name)) then - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - endif - type is (FmsNetcdfFile_t) - if (.not.variable_exists(fptr, axis_name)) then - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - endif - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The file object is not the right type.", FATAL) - end select - endif - - ELSE -!> @note Check if the time variable is registered. It's possible that is_time_axis_registered is set to true if using -!! time-templated files because they aren't closed when done writing. An alternative to this set up would be to put -!! variable_exists into the if statement with an .or. so that it gets registered. - is_time_axis_registered = variable_exists(fptr,trim(axis_name),.true.) - if (allocated(fptr%pelist) .and. .not. is_time_axis_registered) then - select type (fptr) - type is (FmsNetcdfDomainFile_t) - call register_axis(fptr, trim(axis_name), unlimited ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - is_time_axis_registered = .true. - if (present(time_axis_registered)) time_axis_registered = is_time_axis_registered - type is (FmsNetcdfUnstructuredDomainFile_t) - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - is_time_axis_registered = .true. - type is (FmsNetcdfFile_t) - call register_axis(fptr, trim(axis_name), unlimited ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - is_time_axis_registered = .true. - if (present(time_axis_registered)) time_axis_registered = is_time_axis_registered - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The file object is not the right type.", FATAL) - end select - endif - END IF - END IF + !> If the axis is not in a domain, register it as a normal dimension + call register_axis(fileob, axis_name, dimension_length=size(axis_data)) + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + istart = lbound(axis_data,1) + iend = ubound(axis_data,1) + ENDIF !! IF ( Domain .NE. null_domain1d ) + + if (length <= 0) then + !> @note Check if the time variable is registered. It's possible that is_time_axis_registered is set to true if using + !! time-templated files because they aren't closed when done writing. An alternative to this set up would be to put + !! variable_exists into the if statement with an .or. so that it gets registered. + is_time_axis_registered = variable_exists(fileob,trim(axis_name),.true.) + if (.not. is_time_axis_registered) then + call register_axis(fileob, trim(axis_name), unlimited ) + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + is_time_axis_registered = .true. + if (present(time_axis_registered)) time_axis_registered = is_time_axis_registered + endif !! if (.not. is_time_axis_registered) + endif !! if (length <= 0) + + !> Add the attributes + if(trim(axis_units) .ne. "none") call register_variable_attribute(fileob, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) + call register_variable_attribute(fileob, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) + if(trim(axis_cart_name).ne."N") call register_variable_attribute(fileob, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) + + if (length > 0 ) then + !> If not a time axis, add the positive attribute and write the data + select case (axis_direction) + case (1) + call register_variable_attribute(fileob, axis_name, "positive", "up", str_len=len_trim("up")) + case (-1) + call register_variable_attribute(fileob, axis_name, "positive", "down", str_len=len_trim("down")) + end select + call write_data(fileob, axis_name, axis_data(istart:iend) ) + endif - ! Write axis attributes - id_axis = mpp_get_id(Axis_types(num_axis_in_file)) - CALL write_attribute_meta(file_unit, id_axis, num_attributes, attributes, err_msg, varname=axis_name, fileob=fileob) + !> Write additional axis attributes, from diag_axis_add_attribute calls + CALL write_attribute_meta(file_unit, num_attributes, attributes, err_msg, varname=axis_name, fileob=fileob) IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN CALL error_mesg('diag_output_mod::write_axis_meta_data', TRIM(err_msg), FATAL) END IF - !---- write additional attribute (calendar_type) for time axis ---- - !---- NOTE: calendar attribute is compliant with CF convention - !---- http://www.cgd.ucar.edu/cms/eaton/netcdf/CF-current.htm#cal + !> Write additional attribute (calendar_type) for time axis ---- + !> @note calendar attribute is compliant with CF convention + !! http://www.cgd.ucar.edu/cms/eaton/netcdf/CF-current.htm#cal IF ( axis_cart_name == 'T' ) THEN time_axis_flag(num_axis_in_file) = .TRUE. - id_time_axis = mpp_get_id(Axis_types(num_axis_in_file)) + id_time_axis = num_axis_in_file calendar = get_calendar_type() @@ -649,7 +376,6 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ call register_variable_attribute(fileob, axis_name, "calendar", & lowercase(TRIM(valid_calendar_types(calendar))), str_len=len_trim(valid_calendar_types(calendar)) ) IF ( time_ops1 ) THEN - call register_variable_attribute(fileob, axis_name, 'bounds', TRIM(axis_name)//'_bnds', str_len=len_trim(TRIM(axis_name)//'_bnds')) END IF call set_fileobj_time_name(fileob, axis_name) @@ -659,7 +385,7 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ DEALLOCATE(axis_data) - ! Deallocate attributes + !> Deallocate attributes IF ( ALLOCATED(attributes) ) THEN DO j=1, num_attributes IF ( allocated(attributes(j)%fatt ) ) THEN @@ -688,7 +414,7 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ length = get_axis_global_length ( id_axis ) ALLOCATE(axis_data(length)) CALL get_diag_axis(id_axis, axis_name, axis_units, axis_long_name, axis_cart_name,& - & axis_direction, axis_edges, Domain, DomainU, axis_data, num_attributes, attributes) + & axis_direction, axis_edges, Domain, DomainU, axis_data) ! ---- write edges attribute to original axis ---- call register_variable_attribute(fileob, axis_name_current, "edges",trim(axis_name), str_len=len_trim(axis_name)) @@ -699,101 +425,30 @@ SUBROUTINE write_axis_meta_data_fms2_io(file_unit, axes, fileob, time_ops, time_ edge_axis_flag(num_axis_in_file) = .TRUE. time_axis_flag (num_axis_in_file) = .FALSE. - ! ---- write edges axis to file ---- - IF ( Domain .NE. null_domain1d ) THEN - ! assume domain decomposition is irregular and loop through all prev and next - ! domain pointers extracting domain extents. Assume all pes are used in - ! decomposition - CALL mpp_get_global_domain(Domain, begin=gbegin, END=gend, size=gsize) - CALL mpp_get_layout(Domain, ndivs) - IF ( ndivs .NE. 1 ) THEN - IF ( ALLOCATED(axis_extent) ) DEALLOCATE(axis_extent) - ALLOCATE(axis_extent(0:ndivs-1)) - CALL mpp_get_compute_domains(Domain,size=axis_extent(0:ndivs-1)) - gend=gend+1 - axis_extent(ndivs-1)= axis_extent(ndivs-1)+1 - IF ( ALLOCATED(pelist) ) DEALLOCATE(pelist) - ALLOCATE(pelist(0:ndivs-1)) - CALL mpp_get_pelist(Domain,pelist) - END IF - END IF - !> Add edges axis with fms2_io - select type (fptr) - type is (FmsNetcdfUnstructuredDomainFile_t) - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - type is (FmsNetcdfDomainFile_t) - if (.not.variable_exists(fptr, axis_name)) then - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - endif - type is (FmsNetcdfFile_t) - if (.not.variable_exists(fptr, axis_name)) then - call register_axis(fptr, axis_name, size(axis_data) ) - call register_field(fptr, axis_name, type_str, (/axis_name/) ) - if(trim(axis_units) .ne. "none") call register_variable_attribute(fptr, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) - call register_variable_attribute(fptr, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) - if(trim(axis_cart_name).ne."N") call register_variable_attribute(fptr, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) - select case (axis_direction) - case (1) - call register_variable_attribute(fptr, axis_name, "positive", "up", str_len=len_trim("up")) - case (-1) - call register_variable_attribute(fptr, axis_name, "positive", "down", str_len=len_trim("down")) - end select - call write_data(fptr, axis_name, axis_data) - endif - class default - call error_mesg("diag_output_mod::write_axis_meta_data", & - "The file object unstructured 2 is not the right type.", FATAL) - end select - ! Write edge axis attributes - id_axis = mpp_get_id(Axis_types(num_axis_in_file)) -! CALL write_attribute_meta(file_unit, id_axis, num_attributes, attributes, err_msg) - IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN - CALL error_mesg('diag_output_mod::write_axis_meta_data', TRIM(err_msg), FATAL) - END IF + if (.not.variable_exists(fileob, axis_name)) then + call register_axis(fileob, axis_name, size(axis_data) ) + call register_field(fileob, axis_name, type_str, (/axis_name/) ) + if(trim(axis_units) .ne. "none") call register_variable_attribute(fileob, axis_name, "units", trim(axis_units), str_len=len_trim(axis_units)) + call register_variable_attribute(fileob, axis_name, "long_name", trim(axis_long_name), str_len=len_trim(axis_long_name)) + if(trim(axis_cart_name).ne."N") call register_variable_attribute(fileob, axis_name, "axis",trim(axis_cart_name), str_len=len_trim(axis_cart_name)) + select case (axis_direction) + case (1) + call register_variable_attribute(fileob, axis_name, "positive", "up", str_len=len_trim("up")) + case (-1) + call register_variable_attribute(fileob, axis_name, "positive", "down", str_len=len_trim("down")) + end select + call write_data(fileob, axis_name, axis_data) + endif !! if (.not.variable_exists(fileob, axis_name)) DEALLOCATE (axis_data) - ! Deallocate attributes - IF ( ALLOCATED(attributes) ) THEN - DO j=1, num_attributes - IF ( allocated(attributes(j)%fatt ) ) THEN - DEALLOCATE(attributes(j)%fatt) - END IF - IF ( allocated(attributes(j)%iatt ) ) THEN - DEALLOCATE(attributes(j)%iatt) - END IF - END DO - DEALLOCATE(attributes) - END IF END DO - END SUBROUTINE write_axis_meta_data_fms2_io + END SUBROUTINE write_axis_meta_data !> @brief Write the field meta data to file. !! @return diag_fieldtype Field !! @details The meta data for the field is written to the file indicated by file_unit - FUNCTION write_field_meta_data_fms2_io ( file_unit, name, axes, units, long_name, range, pack, mval,& + FUNCTION write_field_meta_data ( file_unit, name, axes, units, long_name, range, pack, mval,& & avg_name, time_method, standard_name, interp_method, attributes, num_attributes, & & use_UGdomain, fileob) result ( Field ) INTEGER, INTENT(in) :: file_unit !< Output file unit number @@ -937,45 +592,9 @@ FUNCTION write_field_meta_data_fms2_io ( file_unit, name, axes, units, long_name Field%miss_pack_present = .FALSE. END IF - !------ write meta data and return fieldtype ------- -!!! Fill in mpp fieldtype for field%field - IF ( use_range ) THEN - IF ( Field%miss_present ) THEN - CALL fillin_fieldtype( Field%Field,& - & Axis_types(axis_indices(1:num)),& - & name, units, long_name,& - & RANGE(1), RANGE(2),& - & missing=Field%miss_pack,& - & fill=Field%miss_pack,& - & scale=scale, add=add, pack=ipack,& - & time_method=time_method) - ELSE - CALL fillin_fieldtype( Field%Field,& - & Axis_types(axis_indices(1:num)),& - & name, units, long_name,& - & RANGE(1), RANGE(2),& - & missing=CMOR_MISSING_VALUE,& - & fill=CMOR_MISSING_VALUE,& - & scale=scale, add=add, pack=ipack,& - & time_method=time_method) - END IF - ELSE - IF ( Field%miss_present ) THEN - CALL fillin_fieldtype( Field%Field,& - & Axis_types(axis_indices(1:num)),& - & name, units, long_name,& - & missing=Field%miss_pack,& - & fill=Field%miss_pack,& - & pack=ipack, time_method=time_method) - ELSE - CALL fillin_fieldtype( Field%Field,& - & Axis_types(axis_indices(1:num)),& - & name, units, long_name,& - & missing=CMOR_MISSING_VALUE,& - & fill=CMOR_MISSING_VALUE,& - & pack=ipack, time_method=time_method) - END IF - END IF + !< Save the fieldname in the diag_fieldtype, so it can be used later + field%fieldname = name + if (.not. variable_exists(fileob,name)) then ! ipack Valid values: ! 1 = 64bit @@ -1029,7 +648,7 @@ FUNCTION write_field_meta_data_fms2_io ( file_unit, name, axes, units, long_name IF ( PRESENT(num_attributes) ) THEN IF ( PRESENT(attributes) ) THEN IF ( num_attributes .GT. 0 .AND. allocated(attributes) ) THEN - CALL write_attribute_meta(file_unit, mpp_get_id(Field%Field), num_attributes, attributes, time_method, err_msg, fileob=fileob, varname=name) + CALL write_attribute_meta(file_unit, num_attributes, attributes, time_method, err_msg, fileob=fileob, varname=name) IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN CALL error_mesg('diag_output_mod::write_field_meta_data',& & TRIM(err_msg)//" Contact the developers.", FATAL) @@ -1084,20 +703,19 @@ FUNCTION write_field_meta_data_fms2_io ( file_unit, name, axes, units, long_name Field%tile_count = get_tile_count ( axes ) Field%DomainU = get_domainUG ( axes(1) ) - END FUNCTION write_field_meta_data_fms2_io + END FUNCTION write_field_meta_data !> \brief Write out attribute meta data to file !! !! Write out the attribute meta data to file, for field and axes - SUBROUTINE write_attribute_meta_fms2_io(file_unit, id, num_attributes, attributes, time_method, err_msg, varname, fileob) + SUBROUTINE write_attribute_meta(file_unit, num_attributes, attributes, time_method, err_msg, varname, fileob) INTEGER, INTENT(in) :: file_unit !< File unit number - INTEGER, INTENT(in) :: id !< ID of field, file, axis to get attribute meta data INTEGER, INTENT(in) :: num_attributes !< Number of attributes to write TYPE(diag_atttype), DIMENSION(:), INTENT(in) :: attributes !< Array of attributes CHARACTER(len=*), INTENT(in), OPTIONAL :: time_method !< To include in cell_methods attribute if present CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Return error message CHARACTER(len=*), INTENT(IN), OPTIONAL :: varname !< The name of the variable -class(FmsNetcdfFile_t), intent(inout) :: fileob + class(FmsNetcdfFile_t), intent(inout) :: fileob !< FMS2_io fileobj INTEGER :: i, att_len CHARACTER(len=1280) :: att_str @@ -1143,7 +761,7 @@ SUBROUTINE write_attribute_meta_fms2_io(file_unit, id, num_attributes, attribute END IF END SELECT END DO - END SUBROUTINE write_attribute_meta_fms2_io + END SUBROUTINE write_attribute_meta !> @brief Writes axis data to file. !! @details Writes axis data to file. This subroutine is to be called once per file @@ -1158,95 +776,26 @@ SUBROUTINE done_meta_data(file_unit) num_axis_in_file = 0 END SUBROUTINE done_meta_data - !> @brief Outputs the diagnostic data to a file using fms2_io taking a field object as input - subroutine diag_field_write_field (field, buffer, static, fileob, file_num, fileobjU, fileobj, fileobjND, fnum_for_domain, time_in) - TYPE(diag_fieldtype), INTENT(inout) :: Field !< - REAL , INTENT(inout) :: buffer(:,:,:,:) - logical, intent(in), optional :: static - class(FmsNetcdfFile_t), optional, intent(inout),target :: fileob - class(FmsNetcdfFile_t), pointer :: fptr => null() - integer, intent(in), optional :: file_num - type(FmsNetcdfUnstructuredDomainFile_t),intent(inout), optional :: fileobjU(:) - type(FmsNetcdfDomainFile_t),intent(inout), optional:: fileobj(:) - type(FmsNetcdfFile_t),intent(inout), optional:: fileobjND(:) - character(len=2), intent(in), optional :: fnum_for_domain - INTEGER, OPTIONAL, INTENT(in) :: time_in - integer :: time - if (present(static)) then - if (static) time = 0 - elseif (present(time_in)) then - time = time_in - else - time = 0 - endif - - if (present(fileob)) then !> Write output to the fileob file - fptr => fileob - select type (fptr) - type is (FmsNetcdfFile_t) - call write_data (fptr,trim(mpp_get_field_name(field%field)),buffer) - type is (FmsNetcdfDomainFile_t) - call write_data (fptr,trim(mpp_get_field_name(field%field)),buffer) - type is (FmsNetcdfUnstructuredDomainFile_t) - call write_data (fptr,trim(mpp_get_field_name(field%field)),buffer) - class default - call error_mesg("diag_field_write","fileob passed in is not one of the FmsNetcdfFile_t types",fatal) - end select - elseif (present(file_num) .and. present(fileobjU) .and. present(fileobjND) .and. present(fileobj) .and. present(fnum_for_domain)) then - !> Figure out which file object to write output to -! if (fnum_for_domain == "2d" .or. fnum_for_domain == "nd") then - if (fnum_for_domain == "2d" ) then - if (check_if_open(fileobj(file_num))) then - if (time == 0) then - call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), buffer) - else - call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time) - endif - endif - elseif (fnum_for_domain == "nd") then - if (check_if_open(fileobjND (file_num)) ) then - if (time == 0) then - call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), buffer) - else - call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time) - endif - endif - elseif (fnum_for_domain == "ug") then - if (time == 0) then - call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), buffer) - else - call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time) - endif - else - call error_mesg("diag_field_write","No file object is associated with this file number",fatal) - endif - elseif (present(file_num) ) then - write (6,*) present(file_num) ,present(fileobjU) , present(fileobjND) , present(fileobj) , present(fnum_for_domain) - call error_mesg("diag_field_write","When FILE_NUM is used to determine which file object to use,"& - //" You must also include fileobjU, fileobj, fileonjND, and fnum_for_domain",fatal) - else - call error_mesg("diag_field_write","You must include a fileob or a file_num.",fatal) - endif - end subroutine diag_field_write_field - !> \brief Writes diagnostic data out using fms2_io routine. - subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num, fileobjU, fileobj, fileobjND, fnum_for_domain, time_in) - CHARACTER(len=*), INTENT(in) :: varname !< - REAL , INTENT(inout) :: buffer(:,:,:,:) - logical, intent(in), optional :: static - class(FmsNetcdfFile_t), intent(inout), optional, target :: fileob - class(FmsNetcdfFile_t), pointer :: fptr => null() - integer, intent(in), optional :: file_num - type(FmsNetcdfUnstructuredDomainFile_t),intent(inout), optional :: fileobjU(:) - type(FmsNetcdfDomainFile_t),intent(inout), optional:: fileobj(:) - type(FmsNetcdfFile_t),intent(inout), optional:: fileobjND(:) - character(len=2), intent(in), optional :: fnum_for_domain - INTEGER, OPTIONAL, INTENT(in) :: time_in - integer :: time + subroutine diag_field_write (varname, buffer, static, file_num, fileobjU, fileobj, fileobjND, fnum_for_domain, time_in) + CHARACTER(len=*), INTENT(in) :: varname !< Variable name + REAL , INTENT(inout) :: buffer(:,:,:,:) !< Buffer containing the variable data + logical, intent(in) :: static !< Flag indicating if a variable is static + integer, intent(in) :: file_num !< Index in the fileobj* types array + type(FmsNetcdfUnstructuredDomainFile_t), intent(inout) :: fileobjU(:) !< Array of non domain decomposed fileobj + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj(:) !< Array of domain decomposed fileobj + type(FmsNetcdfFile_t), intent(inout) :: fileobjND(:) !< Array of unstructured domain fileobj + character(len=2), intent(in) :: fnum_for_domain !< String indicating the type of domain + !! "2d" domain decomposed + !! "ug" unstructured domain decomposed + !! "nd" no domain + INTEGER, OPTIONAL, INTENT(in) :: time_in !< Time index + + integer :: time !< Time index real,allocatable :: local_buffer(:,:,:,:) !< Buffer containing the data will be sent to fms2io !> Set up the time. Static field and default time is 0 - if (present(static) .and. static) then + if ( static ) then time = 0 elseif (present(time_in)) then time = time_in @@ -1254,9 +803,14 @@ subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num, time = 0 endif - !> If the variable is 2D, switch the n_diurnal_samples and nz dimension, so local_buffer has - !! dimension (nx, ny, n_diurnal_samples, nz). - if (size(buffer,3) .eq. 1) then + if (size(buffer,3) .eq. 1 .and. size(buffer,2) .eq. 1) then + !> If the variable is 1D, switch the buffer so that n_diurnal_samples is + !! the second dimension (nx, n_diurnal_samples, 1, 1) + allocate(local_buffer(size(buffer,1),size(buffer,4),size(buffer,2),size(buffer,3))) + local_buffer(:,:,1,1) = buffer(:,1,1,:) + else if (size(buffer,3) .eq. 1) then + !> If the variable is 2D, switch the n_diurnal_samples and nz dimension, so local_buffer has + !! dimension (nx, ny, n_diurnal_samples, 1). allocate(local_buffer(size(buffer,1),size(buffer,2),size(buffer,4),size(buffer,3))) local_buffer(:,:,:,1) = buffer(:,:,1,:) else @@ -1264,49 +818,34 @@ subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num, local_buffer = buffer(:,:,:,:) endif - if (present(fileob)) then !> Write output to the fileob file - fptr => fileob - select type (fptr) - type is (FmsNetcdfFile_t) - call write_data (fptr,trim(varname),local_buffer) - type is (FmsNetcdfDomainFile_t) - call write_data (fptr,trim(varname),local_buffer) - type is (FmsNetcdfUnstructuredDomainFile_t) - call write_data (fptr,trim(varname),local_buffer) - class default - call error_mesg("diag_field_write","fileob passed in is not one of the FmsNetcdfFile_t types",fatal) - end select - elseif (present(file_num) .and. present(fileobjU) .and. present(fileobj) .and. present(fileobjND) .and. present(fnum_for_domain)) then !> Figure out which file object to write output to - if (fnum_for_domain == "2d" ) then - if (check_if_open(fileobj(file_num))) then - call write_data (fileobj (file_num), trim(varname), local_buffer, unlim_dim_level=time ) - endif - elseif (fnum_for_domain == "nd") then - if (check_if_open(fileobjND (file_num)) ) then - call write_data (fileobjND (file_num), trim(varname), local_buffer, unlim_dim_level=time) - endif - elseif (fnum_for_domain == "ug") then - call write_data (fileobjU(file_num), trim(varname), local_buffer, unlim_dim_level=time) - else - call error_mesg("diag_field_write","No file object is associated with this file number",fatal) - endif - elseif (present(file_num) ) then - call error_mesg("diag_field_write","When FILE_NUM is used to determine which file object to use,"& - //" You must also include fileobjU, fileobj, and fnum_for_domain",fatal) + if (fnum_for_domain == "2d" ) then + if (check_if_open(fileobj(file_num))) then + call write_data (fileobj (file_num), trim(varname), local_buffer, unlim_dim_level=time ) + endif + elseif (fnum_for_domain == "nd") then + if (check_if_open(fileobjND (file_num)) ) then + call write_data (fileobjND (file_num), trim(varname), local_buffer, unlim_dim_level=time) + endif + elseif (fnum_for_domain == "ug") then + if (check_if_open(fileobjU(file_num))) then + call write_data (fileobjU(file_num), trim(varname), local_buffer, unlim_dim_level=time) + endif else - call error_mesg("diag_field_write","You must include a fileob or a file_num.",fatal) + call error_mesg("diag_field_write","fnum_for_domain must be '2d', 'nd', or 'ug'",fatal) endif + deallocate(local_buffer) - end subroutine diag_field_write_varname + end subroutine diag_field_write + !> \brief Writes the time data to the history file subroutine diag_write_time (fileob,rtime_value,time_index,time_name) - class(FmsNetcdfFile_t), intent(inout),target :: fileob !< fms2_io file object - class(FmsNetcdfFile_t), pointer :: fptr => null() - real, intent(in) :: rtime_value !< The value of time to be written - integer, intent(in) :: time_index !< The index of the time variable - character(len=*),intent(in),optional :: time_name !< The name of the time variable - character(len=:),allocatable :: name_time !< The name of the time variable + class(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2_io file object + real, intent(in) :: rtime_value !< The value of time to be written + integer, intent(in) :: time_index !< The index of the time variable + character(len=*), intent(in), optional :: time_name !< The name of the time variable + character(len=:),allocatable :: name_time !< The name of the time variable + !> Get the name of the time variable if (present(time_name)) then allocate(character(len=len(time_name)) :: name_time) @@ -1319,7 +858,6 @@ subroutine diag_write_time (fileob,rtime_value,time_index,time_name) call write_data (fileob, trim(name_time), rtime_value, unlim_dim_level=time_index) !> Cleanup if (allocated(name_time)) deallocate(name_time) - if (associated(fptr)) nullify(fptr) end subroutine diag_write_time !> @brief Return the axis index number. diff --git a/diag_manager/diag_table.F90 b/diag_manager/diag_table.F90 index 587472c85..bd56b324f 100644 --- a/diag_manager/diag_table.F90 +++ b/diag_manager/diag_table.F90 @@ -221,9 +221,8 @@ MODULE diag_table_mod - USE mpp_io_mod, ONLY: mpp_open, MPP_RDONLY - USE mpp_mod, ONLY: read_ascii_file, get_ascii_file_num_lines - USE fms_mod, ONLY: fms_error_handler, error_mesg, file_exist, stdlog, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase, close_file + 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 @@ -309,7 +308,7 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) 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=DT_LINE_LENGTH), DIMENSION(:), ALLOCATABLE :: diag_table + CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: diag_table TYPE(file_description_type) :: temp_file TYPE(field_description_type) :: temp_field @@ -331,10 +330,8 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) ! get the stdlog unit number stdlog_unit = stdlog() - num_lines = get_ascii_file_num_lines('diag_table', DT_LINE_LENGTH) - allocate(diag_table(num_lines)) - call read_ascii_file('diag_table', DT_LINE_LENGTH, diag_table) + call ascii_read('diag_table', diag_table, num_lines=num_lines) ! Read in the global file labeling string READ (UNIT=diag_table(1), FMT=*, IOSTAT=mystat) global_descriptor @@ -472,40 +469,6 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg) END SUBROUTINE parse_diag_table - !> @brief Open the diag_table file, and return the Fortran file unit number. - SUBROUTINE open_diag_table(iunit, iostat, err_msg) - INTEGER, INTENT(out) :: iunit !< Fortran file unit number of the diag_table. - INTEGER, INTENT(out), OPTIONAL, TARGET :: iostat !< Status of opening file. If iostat == 0, file exists. - !! If iostat > 0, the diag_table file does not exist. - CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< String to hold the return error message. - - INTEGER, TARGET :: mystat - INTEGER, POINTER :: pstat - - IF ( PRESENT(iostat) ) THEN - pstat => iostat - ELSE - pstat => mystat - END IF - - IF ( .NOT.file_exist('diag_table') ) THEN - pstat = 1 - IF ( fms_error_handler('diag_table_mod::open_diag_table',& - & 'diag_table file does not exist.', err_msg) ) RETURN - ELSE - pstat = 0 - END IF - - CALL mpp_open(iunit, 'diag_table', action=MPP_RDONLY) - END SUBROUTINE open_diag_table - - !> @brief Closes the diag_table file. - SUBROUTINE close_diag_table(iunit) - INTEGER, INTENT(in) :: iunit !< Fortran file unit number of the diag_table. - - CALL close_file(iunit) - END SUBROUTINE close_diag_table - !> @brief parse_file_line parses a file description line from the diag_table file, and returns a !! TYPE(file_description_type). The calling function, would then need to call the init_file to initialize !! the diagnostic output file. diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 07ad463c0..618702c30 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -65,7 +65,6 @@ MODULE diag_util_mod & write_version_number, do_cf_compliance USE fms_io_mod, ONLY: get_tile_string, return_domain, string USE fms2_io_mod, ONLY: fms2_io_get_instance_filename => get_instance_filename - USE fms_io_mod, ONLY: mpp_io_get_instance_filename => get_instance_filename USE mpp_domains_mod,ONLY: domain1d, domain2d, mpp_get_compute_domain, null_domain1d, null_domain2d,& & OPERATOR(.NE.), OPERATOR(.EQ.), mpp_modify_domain, mpp_get_domain_components,& & mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id, mpp_mosaic_defined, mpp_get_tile_npes,& @@ -73,7 +72,6 @@ MODULE diag_util_mod USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,& & increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),& & OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==) - USE mpp_io_mod, ONLY: mpp_close USE mpp_mod, ONLY: mpp_npes USE fms_io_mod, ONLY: get_mosaic_tile_file_ug USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE @@ -1546,7 +1544,6 @@ SUBROUTINE opening_file(file, time, filename_time) INTEGER, DIMENSION(6) :: axes INTEGER, ALLOCATABLE :: axesc(:) ! indices if compressed axes associated with the field LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields - LOGICAL :: all_scalar_or_1d CHARACTER(len=7) :: prefix CHARACTER(len=7) :: avg_name = 'average' CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name, req_fields, fieldname @@ -1560,6 +1557,7 @@ SUBROUTINE opening_file(file, time, filename_time) INTEGER :: is, ie, last, ind character(len=2) :: fnum_domain class(FmsNetcdfFile_t), pointer :: fileob + integer :: actual_num_axes !< The actual number of axes to write including time aux_present = .FALSE. match_aux_name = .FALSE. @@ -1611,13 +1609,11 @@ SUBROUTINE opening_file(file, time, filename_time) ! JWD: This is a klooge; need something more robust domain2 = NULL_DOMAIN2D domainU = NULL_DOMAINUG - all_scalar_or_1d = .TRUE. DO j = 1, files(file)%num_fields field_num = files(file)%fields(j) if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE num_axes = output_fields(field_num)%num_axes IF ( num_axes > 1 ) THEN - all_scalar_or_1d = .FALSE. domain2 = get_domain2d ( output_fields(field_num)%axes(1:num_axes) ) domainU = get_domainUG ( output_fields(field_num)%axes(1) ) IF ( domain2 .NE. NULL_DOMAIN2D ) EXIT @@ -1628,63 +1624,20 @@ SUBROUTINE opening_file(file, time, filename_time) END IF END DO - IF (.NOT. all_scalar_or_1d) THEN - IF (domainU .NE. null_domainUG .AND. domain2 .NE. null_domain2D) THEN - CALL error_mesg('diag_util_mod::opening_file', & - 'Domain2 and DomainU are somehow both set.', & + IF (domainU .NE. null_domainUG .AND. domain2 .NE. null_domain2D) THEN + CALL error_mesg('diag_util_mod::opening_file', & + 'Domain2 and DomainU are somehow both set.', & FATAL) - ELSEIF (domainU .EQ. null_domainUG) THEN - IF (domain2 .EQ. NULL_DOMAIN2D) THEN - CALL return_domain(domain2) - ENDIF - - IF (domain2 .EQ. NULL_DOMAIN2D) THEN - - !Fix for the corner-case when you have a file that contains - !2D field(s) that is not associated with a domain tile, as - !is usually assumed. - - !This is very confusing, but I will try to explain. The - !all_scalar_or_1d flag determines if the file name is associated - !with a domain (i.e. has ".tilex." in the file name). A value - !of .FALSE. for the all_scalar_or_1d flag signals that the - !file name is associated with a domain tile. Normally, - !files that contain at least one two-dimensional field are - !assumed to be associated with a specific domain tile, and - !thus have the value of the all_scalar_or_1d flag set to - !.FALSE. It is possible, however, to have a file that contains - !two-dimensional fields that is not associated with a domain tile - !(i.e., if you make it into this branch.). If that is the - !case, then reset the all_scalar_or_1d flag back to .TRUE. - !Got that? - all_scalar_or_1d = .TRUE. - - ELSE - ntileMe = mpp_get_current_ntile(domain2) - ALLOCATE(tile_id(ntileMe)) - tile_id = mpp_get_tile_id(domain2) - fname = TRIM(filename) - IF ( mpp_get_ntile_count(domain2) > 1 ) THEN - CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(files(file)%tile_count)) - ELSEIF ( tile_id(1) > 1 ) then - CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(1)) - ENDIF - DEALLOCATE(tile_id) - ENDIF - ENDIF - ENDIF - IF ( domainU .ne. null_domainUG) then - fname = TRIM(filename) - CALL get_mosaic_tile_file_ug(fname,filename,domainU) ENDIF + IF ( allocated(files(file)%attributes) ) THEN - CALL diag_output_init(filename, files(file)%format, global_descriptor,& - & files(file)%file_unit, all_scalar_or_1d, domain2, domainU,& + CALL diag_output_init(filename, global_descriptor,& + & files(file)%file_unit, domain2, domainU,& & fileobj(file),fileobjU(file), fileobjND(file), fnum_for_domain(file),& & attributes=files(file)%attributes(1:files(file)%num_attributes)) ELSE - CALL diag_output_init(filename, files(file)%format, global_descriptor,& - & files(file)%file_unit, all_scalar_or_1d, domain2,domainU, & + CALL diag_output_init(filename, global_descriptor,& + & files(file)%file_unit, domain2,domainU, & & fileobj(file),fileobjU(file),fileobjND(file),fnum_for_domain(file)) END IF !> update fnum_for_domain with the correct domain @@ -1760,43 +1713,37 @@ SUBROUTINE opening_file(file, time, filename_time) allocate(files(file)%is_time_axis_registered) files(file)%is_time_axis_registered = .false. endif + if (time_ops) then + !< If the file contains time_average fields write the "time" and "nv" dimension + actual_num_axes = num_axes + 2 + axes(num_axes + 2) = files(file)%time_bounds_id + else + !< If the file doesn't contain time_average fields write the "time" dimension + actual_num_axes = num_axes + 1 + endif + if (fnum_for_domain(file) == "2d") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1),fileobj(file), time_ops=time_ops, & + CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobj(file), time_ops=time_ops, & time_axis_registered=files(file)%is_time_axis_registered) elseif (fnum_for_domain(file) == "nd") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1),fileobjnd(file), time_ops=time_ops, & + CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobjnd(file), time_ops=time_ops, & time_axis_registered=files(file)%is_time_axis_registered) elseif (fnum_for_domain(file) == "ug") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1),fileobjU(file), time_ops=time_ops, & + CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobjU(file), time_ops=time_ops, & time_axis_registered=files(file)%is_time_axis_registered) endif - IF ( time_ops ) THEN - axes(num_axes + 2) = files(file)%time_bounds_id - if (fnum_for_domain(file) == "2d") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2),fileobj(file), & - time_axis_registered=files(file)%is_time_axis_registered) - elseif (fnum_for_domain(file) == "nd") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2),fileobjND(file), & - time_axis_registered=files(file)%is_time_axis_registered) - elseif (fnum_for_domain(file) == "ug") then - CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2),fileobjU(file), & - time_axis_registered=files(file)%is_time_axis_registered) - endif - END IF + ! write metadata for axes used in compression-by-gathering, e.g. for unstructured ! grid DO k = 1, num_axes IF (axis_is_compressed(axes(k))) THEN CALL get_compressed_axes_ids(axes(k), axesc) ! returns allocatable array - if (fnum_for_domain(file) == "2d" ) then - CALL write_axis_meta_data(files(file)%file_unit, axesc,fileobj(file), & - time_axis_registered=files(file)%is_time_axis_registered) - elseif (fnum_for_domain(file) == "nd") then - CALL write_axis_meta_data(files(file)%file_unit, axesc,fileobjND(file), & - time_axis_registered=files(file)%is_time_axis_registered) - elseif (fnum_for_domain(file) == "ug") then + if (fnum_for_domain(file) == "ug") then CALL write_axis_meta_data(files(file)%file_unit, axesc,fileobjU(file), & time_axis_registered=files(file)%is_time_axis_registered) + else + CALL error_mesg('diag_util_mod::opening_file::'//trim(filename), "Compressed "//& + "dimensions are only allowed with axis in the unstructured dimension", FATAL) endif DEALLOCATE(axesc) ENDIF @@ -2210,6 +2157,11 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, LOGICAL :: final_call, do_write, static_write INTEGER :: i, num REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif + REAL :: time_in_file !< Time in file at the beginning of this call + + !< Save the current time in the file. If the time in the file is not the same as the + !! current time, files(file)%rtime_current will be updated + time_in_file = files(file)%rtime_current do_write = .TRUE. final_call = .FALSE. @@ -2244,8 +2196,8 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, " has gone backwards. There may be missing values for some of the variables",NOTE) endif !> Write data - call diag_field_write (output_fields(field)%output_name, dat, static=static_write, file_num=file, fileobjU=fileobjU, & - fileobj=fileobj, fileobjND=fileobjND, fnum_for_domain=fnum_for_domain(file), time_in=files(file)%time_index) + call diag_field_write (output_fields(field)%output_name, dat, static_write, file, fileobjU, & + fileobj, fileobjND, fnum_for_domain(file), time_in=files(file)%time_index) ! record number of bytes written to this file files(file)%bytes_written = files(file)%bytes_written +& & (SIZE(dat,1)*SIZE(dat,2)*SIZE(dat,3))*(8/output_fields(field)%pack) @@ -2260,37 +2212,28 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, END IF END IF - ! Need to write average axes out; - DO i = 1, files(file)%num_fields - num = files(file)%fields(i) - IF ( output_fields(num)%time_ops .AND. & - input_fields(output_fields(num)%input_field)%register) THEN - ! time needs to be between start_dif and end_dif to prevent duplicate writes on time_bnds - IF ( num == field ) THEN - IF ( files(file)%rtime_current >= start_dif .AND. files(file)%rtime_current <= end_dif) THEN - ! Output the axes if this is first time-averaged field - time_data(1, 1, 1, 1) = start_dif - call diag_field_write (files(file)%f_avg_start, time_data(1:1,:,:,:), file_num=file, & - fileobjU=fileobjU, fileobj=fileobj, fileobjND=fileobjND, & - fnum_for_domain=fnum_for_domain(file), time_in=files(file)%time_index) - time_data(2, 1, 1, 1) = end_dif - call diag_field_write (files(file)%f_avg_end, time_data(2:2,:,:,:), file_num=file, & - fileobjU=fileobjU, fileobj=fileobj, fileobjND=fileobjND, & - fnum_for_domain=fnum_for_domain(file), time_in=files(file)%time_index) - ! Compute the length of the average - dt_time(1, 1, 1, 1) = end_dif - start_dif - call diag_field_write (files(file)%f_avg_nitems, dt_time(1:1,:,:,:), file_num=file, & - fileobjU=fileobjU, fileobj=fileobj, fileobjND=fileobjND, & - fnum_for_domain=fnum_for_domain(file), time_in=files(file)%time_index) - ! Include boundary variable for CF compliance - call diag_field_write (files(file)%f_bounds, time_data(1:2,:,:,:), file_num=file, & - fileobjU=fileobjU, fileobj=fileobj, fileobjND=fileobjND, & - fnum_for_domain=fnum_for_domain(file), time_in=files(file)%time_index) - EXIT - END IF - END IF + if (files(file)%rtime_current > time_in_file) then !< If time was written in this call + if (output_fields(field)%time_ops) then !< If this is a time_average field + ! Output the axes if this is first time-averaged field + time_data(1, 1, 1, 1) = start_dif + call diag_field_write (files(file)%f_avg_start%fieldname, time_data(1:1,:,:,:), static_write, file, & + fileobjU, fileobj, fileobjND, & + fnum_for_domain(file), time_in=files(file)%time_index) + time_data(2, 1, 1, 1) = end_dif + call diag_field_write (files(file)%f_avg_end%fieldname, time_data(2:2,:,:,:), static_write, file, & + fileobjU, fileobj, fileobjND, & + fnum_for_domain(file), time_in=files(file)%time_index) + ! Compute the length of the average + dt_time(1, 1, 1, 1) = end_dif - start_dif + call diag_field_write (files(file)%f_avg_nitems%fieldname, dt_time(1:1,:,:,:), static_write, file, & + fileobjU, fileobj, fileobjND, & + fnum_for_domain(file), time_in=files(file)%time_index) + ! Include boundary variable for CF compliance + call diag_field_write (files(file)%f_bounds%fieldname, time_data(1:2,:,:,:), static_write, file, & + fileobjU, fileobj, fileobjND, & + fnum_for_domain(file), time_in=files(file)%time_index) END IF - END DO + END IF ! If write time is greater (equal for the last call) than last_flush for this file, flush it IF ( final_call ) THEN diff --git a/docs/Doxyfile.in b/docs/Doxyfile.in index 345e0d82c..63ac4a508 100644 --- a/docs/Doxyfile.in +++ b/docs/Doxyfile.in @@ -2033,7 +2033,7 @@ INCLUDE_FILE_PATTERNS = *.inc # recursively expanded use the := operator instead of the = operator. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -PREDEFINED = +PREDEFINED = use_yaml # If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this # tag can be used to specify a list of macro names that should be expanded. The diff --git a/docs/grouping.h b/docs/grouping.h index c2c75a631..2e2f7a82d 100644 --- a/docs/grouping.h +++ b/docs/grouping.h @@ -114,6 +114,10 @@ * */ +/** @defgroup parser Parser + * + */ + /** @defgroup platform Platform * */ diff --git a/fms/Makefile.am b/fms/Makefile.am index ea443f17e..5d0cf5b5c 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -31,6 +31,8 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ + fms_c.c \ + fms_c.h \ fms.F90 \ fms_io.F90 \ fms_io_unstructured_field_exist.inc \ diff --git a/fms/fms.F90 b/fms/fms.F90 index 61f5772e3..63decdbae 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -209,7 +209,7 @@ module fms_mod public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, & CLOCK_MODULE_DRIVER, CLOCK_MODULE, & CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA -public :: fms_c2f_string +public :: fms_c2f_string, fms_cstring2cpointer !public from the old fms_io but not exists here public :: string @@ -302,11 +302,19 @@ module fms_mod end interface !> C functions interface + !> @brief converts a kind=c_char to type c_ptr + pure function fms_cstring2cpointer (cs) result (cp) bind(c, name="cstring2cpointer") + import c_char, c_ptr + character(kind=c_char), intent(in) :: cs(*) !< C string input + type (c_ptr) :: cp !< C pointer + end function fms_cstring2cpointer + !> @brief Finds the length of a C-string integer(c_size_t) pure function c_strlen(s) bind(c,name="strlen") import c_size_t, c_ptr type(c_ptr), intent(in), value :: s !< A C-string whose size is desired end function + !> @brief Frees a C pointer subroutine c_free(ptr) bind(c,name="free") import c_ptr @@ -831,7 +839,7 @@ function fms_c2f_string (cstring) result(fstring) allocate(character(len=length) :: fstring) !> Set the length of fstring fstring = string_buffer - + deallocate(string_buffer) end function fms_c2f_string !####################################################################### !> @brief Prints to the log file (or a specified unit) the version id string and diff --git a/fms/fms_c.c b/fms/fms_c.c new file mode 100644 index 000000000..c14f44823 --- /dev/null +++ b/fms/fms_c.c @@ -0,0 +1,8 @@ +#include +#include +#include + +char * cstring2cpointer (char * cs) +{ + return cs; +} diff --git a/fms/fms_c.h b/fms/fms_c.h new file mode 100644 index 000000000..b9636e0fa --- /dev/null +++ b/fms/fms_c.h @@ -0,0 +1,4 @@ +#include +#include +#include +char * cstring2cpointer (char * cs); diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index 05a151b81..7ec87e39d 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -62,6 +62,7 @@ libFMS_la_LIBADD += $(top_builddir)/tracer_manager/libtracer_manager.la libFMS_la_LIBADD += $(top_builddir)/random_numbers/librandom_numbers.la libFMS_la_LIBADD += $(top_builddir)/diag_integral/libdiag_integral.la libFMS_la_LIBADD += $(top_builddir)/sat_vapor_pres/libsat_vapor_pres.la +libFMS_la_LIBADD += $(top_builddir)/parser/libparser.la libFMS_la_LIBADD += $(top_builddir)/libFMS_mod.la # At least one source file must be included to please Automake. diff --git a/mpp/include/mpp_do_updateV_nonblock.h b/mpp/include/mpp_do_updateV_nonblock.h index a1c0ebf8e..aad3ba5ca 100644 --- a/mpp/include/mpp_do_updateV_nonblock.h +++ b/mpp/include/mpp_do_updateV_nonblock.h @@ -567,6 +567,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u integer :: tMe, dir update_edge_only = BTEST(flags, EDGEONLY) + recv = .false. recv(1) = BTEST(flags,EAST) recv(3) = BTEST(flags,SOUTH) recv(5) = BTEST(flags,WEST) diff --git a/mpp/include/mpp_do_update_nonblock.h b/mpp/include/mpp_do_update_nonblock.h index 4006aa338..5ed53f54a 100644 --- a/mpp/include/mpp_do_update_nonblock.h +++ b/mpp/include/mpp_do_update_nonblock.h @@ -277,6 +277,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type pointer(ptr_field, field) update_edge_only = BTEST(flags, EDGEONLY) + recv = .false. recv(1) = BTEST(flags,EAST) recv(3) = BTEST(flags,SOUTH) recv(5) = BTEST(flags,WEST) diff --git a/parser/Makefile.am b/parser/Makefile.am new file mode 100644 index 000000000..a0b6c6bb0 --- /dev/null +++ b/parser/Makefile.am @@ -0,0 +1,42 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the constants directory of the FMS +# package. + +# Ed Hartnett 2/22/19 + +# Include .h and .mod files. +AM_CPPFLAGS = -I$(top_srcdir)/include +AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) + +# Build this uninstalled convenience library. +noinst_LTLIBRARIES = libparser.la + +# The convenience library depends on its source. +libparser_la_SOURCES = \ + yaml_parser.F90 \ + yaml_parser_binding.c + +MODFILES = \ + yaml_parser_mod.$(FC_MODEXT) +BUILT_SOURCES = $(MODFILES) +nodist_include_HEADERS = $(MODFILES) + +include $(top_srcdir)/mkmods.mk diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 new file mode 100644 index 000000000..74f5a4842 --- /dev/null +++ b/parser/yaml_parser.F90 @@ -0,0 +1,429 @@ +!*********************************************************************** +!* 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 yaml_parser_mod yaml_parser_mod +!> @ingroup parser +!> @brief Routines to use for parsing yaml files + +!> @file +!> @brief File for @ref yaml_parser_mod + +!> @addtogroup yaml_parser_mod +!> @{ +module yaml_parser_mod + +#ifdef use_yaml +use fms_mod, only: fms_c2f_string +use platform_mod +use mpp_mod +use iso_c_binding + +implicit none +private + +public :: open_and_parse_file +public :: get_num_blocks +public :: get_block_ids +public :: get_value_from_key +public :: get_nkeys +public :: get_key_ids +public :: get_key_name +public :: get_key_value +!public :: clean_up +!> @} + +!> @brief Dermine the value of a key from a keyname +!> @ingroup yaml_parser_mod +interface get_value_from_key + module procedure get_value_from_key_0d + module procedure get_value_from_key_1d +end interface get_value_from_key + +!> @brief c functions binding +!> @ingroup yaml_parser_mod +interface + +!> @brief Private c function that opens and parses a yaml file (see yaml_parser_binding.c) +!! @return Flag indicating if the read was sucessful +function open_and_parse_file_wrap(filename, file_id) bind(c) & + result(sucess) + use iso_c_binding, only: c_char, c_int, c_bool + character(kind=c_char), intent(in) :: filename(*) !< Filename of the yaml file + integer(kind=c_int), intent(out) :: file_id !< File id corresponding to the yaml file that was opened + logical(kind=c_bool) :: sucess !< Flag indicating if the read was sucessful +end function open_and_parse_file_wrap + +!> @brief Private c function that checks if a file_id is valid (see yaml_parser_binding.c) +!! @return Flag indicating if the file_id is valid +function is_valid_file_id(file_id) bind(c) & + result(is_valid) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid +end function is_valid_file_id + +!> @brief Private c function that gets the number of key-value pairs in a block (see yaml_parser_binding.c) +!! @return Number of key-value pairs in this block +function get_nkeys_binding(file_id, block_id) bind(c) & + result(nkeys) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: block_id !< Id of the parent_block + integer(kind=c_int) :: nkeys +end function get_nkeys_binding + +!> @brief Private c function that gets the ids of the key-value pairs in a block (see yaml_parser_binding.c) +subroutine get_key_ids_binding(file_id, block_id, key_ids) bind(c) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: block_id !< Id of the parent_block + integer(kind=c_int), intent(inout) :: key_ids(*) !< Ids of the key-value pairs +end subroutine get_key_ids_binding + +!> @brief Private c function that checks if a key_id is valid (see yaml_parser_binding.c) +!! @return Flag indicating if the key_id is valid +function is_valid_key_id(file_id, key_id) bind(c) & + result(is_valid) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: key_id !< Key id to check if valid + logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid +end function is_valid_key_id + +!> @brief Private c function that get the key from a key_id in a yaml file +!! @return Name of the key obtained +function get_key(file_id, key_id) bind(c) & + result(key_name) + use iso_c_binding, only: c_ptr, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: key_id !< Id of the key-value pair of interest + type(c_ptr) :: key_name +end function get_key + +!> @brief Private c function that get the value from a key_id in a yaml file +!! @return String containing the value obtained +function get_value(file_id, key_id) bind(c) & + result(key_value) + use iso_c_binding, only: c_ptr, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: key_id !< Id of the key-value pair of interest + type(c_ptr) :: key_value +end function get_value + +!> @brief Private c function that determines they value of a key in yaml_file (see yaml_parser_binding.c) +!! @return c pointer with the value obtained +function get_value_from_key_wrap(file_id, block_id, key_name, sucess) bind(c) & + result(key_value2) + + use iso_c_binding, only: c_ptr, c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search + integer(kind=c_int), intent(in) :: block_id !< ID corresponding to the block you want the key for + character(kind=c_char), intent(in) :: key_name(*) !< Name of the key you want the value for + integer(kind=c_int), intent(out) :: sucess !< Flag indicating if the call was sucessful + type(c_ptr) :: key_value2 +end function get_value_from_key_wrap + +!> @brief Private c function that determines the number of blocks with block_name in the yaml file +!! (see yaml_parser_binding.c) +!! @return Number of blocks with block_name +function get_num_blocks_all(file_id, block_name) bind(c) & + result(nblocks) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search + character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for + + integer(kind=c_int) :: nblocks +end function get_num_blocks_all + +!> @brief Private c function that determines the number of blocks with block_name that belong to +!! a parent block with parent_block_id in the yaml file (see yaml_parser_binding.c) +!! @return Number of blocks with block_name +function get_num_blocks_child(file_id, block_name, parent_block_id) bind(c) & + result(nblocks) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search + character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for + integer(kind=c_int) :: parent_block_id !< Id of the parent block + + integer(kind=c_int) :: nblocks +end function get_num_blocks_child + +!> @brief Private c function that gets the the ids of the blocks with block_name in the yaml file +!! (see yaml_parser_binding.c) +subroutine get_block_ids_all(file_id, block_name, block_ids) bind(c) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search + character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for + integer(kind=c_int), intent(inout) :: block_ids(*) !< Id of the parent_block +end subroutine get_block_ids_all + +!> @brief Private c function that gets the the ids of the blocks with block_name and that +!! belong to a parent block id in the yaml file (see yaml_parser_binding.c) +subroutine get_block_ids_child(file_id, block_name, block_ids, parent_block_id) bind(c) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search + character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for + integer(kind=c_int), intent(inout) :: block_ids(*) !< Id of the parent_block + integer(kind=c_int) :: parent_block_id !< Id of the parent block +end subroutine get_block_ids_child + +!> @brief Private c function that checks if a block_id is valid (see yaml_parser_binding.c) +!! @return Flag indicating if the block_id is valid +function is_valid_block_id(file_id, block_id) bind(c) & + result(is_valid) + use iso_c_binding, only: c_char, c_int, c_bool + integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer(kind=c_int), intent(in) :: block_id !< Block id to check if valid + logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid +end function is_valid_block_id + +end interface + +!> @addtogroup yaml_parser_mod +!> @{ +contains + +!> @brief Opens and parses a yaml file +!! @return A file id corresponding to the file that was opened +function open_and_parse_file(filename) & + result(file_id) + + character(len=*), intent(in) :: filename !< Filename of the yaml file + logical :: sucess !< Flag indicating if the read was sucessful + + integer :: file_id + + sucess = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) + if (.not. sucess) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") + +end function open_and_parse_file + +!> @brief Gets the key from a file id +subroutine get_key_name(file_id, key_id, key_name) + integer, intent(in) :: key_id !< Id of the key-value pair of interest + integer, intent(in) :: file_id !< File id of the yaml file to search + character(len=*), intent(out) :: key_name + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_key_name call is invalid! Check your call.") + if (.not. is_valid_key_id(file_id, key_id)) call mpp_error(FATAL, "The key id in your get_key_name call is invalid! Check your call.") + + key_name = fms_c2f_string(get_key(file_id, key_id)) + +end subroutine get_key_name + +!> @brief Gets the value from a file id +subroutine get_key_value(file_id, key_id, key_value) + integer, intent(in) :: key_id !< Id of the key-value pair of interest + integer, intent(in) :: file_id !< File id of the yaml file to search + character(len=*), intent(out) :: key_value + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_key_value call is invalid! Check your call.") + if (.not. is_valid_key_id(file_id, key_id)) call mpp_error(FATAL, "The key id in your get_key_value call is invalid! Check your call.") + + key_value = fms_c2f_string(get_value(file_id, key_id)) + +end subroutine get_key_value + +!> @brief Used to dermine the value of a key from a keyname +subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_optional) + integer, intent(in) :: file_id !< File id of the yaml file to search + integer, intent(in) :: block_id !< ID corresponding to the block you want the key for + character(len=*), intent(in) :: key_name !< Name of the key you want the value for + class(*), intent(inout):: key_value !< Value of the key + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key to not exist. + !! If the key does not exist key_value will not be set, so it + !! is the user's responsibility to initialize it before the call + + character(len=255) :: buffer !< String buffer with the value + + type(c_ptr) :: c_buffer !< c pointer with the value + integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully + logical :: optional !< Flag indicating that the key was optional + integer :: err_unit !< integer with io error + + optional = .false. + if (present(is_optional)) optional = is_optional + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_value_from_key call is invalid! Check your call.") + if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, "The block id in your get_value_from_key call is invalid! Check your call.") + + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) + if (sucess == 1) then + buffer = fms_c2f_string(c_buffer) + + select type (key_value) + type is (integer(kind=i4_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to i4") + type is (integer(kind=i8_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to i8") + type is (real(kind=r4_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to r4") + type is (real(kind=r8_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to r8") + type is (character(len=*)) + key_value = buffer + class default + call mpp_error(FATAL, "The type of your buffer in your get_value_from_key call for key "//trim(key_name)//& + &" is not supported. Only i4, i8, r4, r8 and strings are supported.") + end select + else + if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + endif + +end subroutine get_value_from_key_0d + +!> @brief Used' to dermine the 1D value of a key from a keyname +subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_optional) + integer, intent(in) :: file_id !< File id of the yaml file to search + integer, intent(in) :: block_id !< ID corresponding to the block you want the key for + character(len=*), intent(in) :: key_name !< Name of the key you want the value for + class(*), intent(inout):: key_value(:) !< Value of the key + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key' to not exist. + !! If the key does not exist key_value will not be set, so it + !! is the user's responsibility to initialize it before the call + + character(len=255) :: buffer !< String buffer with the value + + type(c_ptr) :: c_buffer !< c pointer with the value + integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully + logical :: optional !< Flag indicating that the key was optional + integer :: err_unit !< integer with io error + + optional=.false. + if (present(is_optional)) optional = is_optional + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_value_from_key call is invalid! Check your call.") + if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, "The block id in your get_value_from_key call is invalid! Check your call.") + + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) + if (sucess == 1) then + buffer = fms_c2f_string(c_buffer) + + select type (key_value) + type is (integer(kind=i4_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to i4") + type is (integer(kind=i8_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to i8") + type is (real(kind=r4_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to r4") + type is (real(kind=r8_kind)) + read(buffer,*, iostat=err_unit) key_value + if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to r8") + type is (character(len=*)) + call mpp_error(FATAL, "get_value_from_key 1d string variables are not supported. Contact developers") + class default + call mpp_error(FATAL, "The type of your buffer in your get_value_from_key call for key "//trim(key_name)//& + &" is not supported. Only i4, i8, r4, r8 and strings are supported.") + end select + else + if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + endif +end subroutine get_value_from_key_1d + +!> @brief Determines the number of blocks with block_name in the yaml file +!! If parent_block_id is present, it only counts those that belong to that block +!! @return Number of blocks with block_name +function get_num_blocks(file_id, block_name, parent_block_id) & + result(nblocks) + + integer, intent(in) :: file_id !< File id of the yaml file to search + character(len=*), intent(in) :: block_name !< The name of the block you are looking for + integer, intent(in), optional :: parent_block_id !< Id of the parent block + integer :: nblocks + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_num_blocks call is invalid! Check your call.") + + if (.not. present(parent_block_id)) then + nblocks=get_num_blocks_all(file_id, trim(block_name)//c_null_char) + else + if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, "The parent_block id in your get_num_blocks call is invalid! Check your call.") + nblocks=get_num_blocks_child(file_id, trim(block_name)//c_null_char, parent_block_id) + endif +end function get_num_blocks + +!> @brief Gets the the ids of the blocks with block_name in the yaml file +!! If parent_block_id is present, it only gets those that belong to that block +subroutine get_block_ids(file_id, block_name, block_ids, parent_block_id) + + integer, intent(in) :: file_id !< File id of the yaml file to search + character(len=*), intent(in) :: block_name !< The name of the block you are looking for + integer, intent(inout) :: block_ids(:) !< Id of blocks with block_name + integer, intent(in), optional :: parent_block_id !< Id of the parent_block + integer :: nblocks_id + integer :: nblocks + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_block_ids call is invalid! Check your call.") + + nblocks_id = size(block_ids) + nblocks = get_num_blocks(file_id, block_name, parent_block_id) + if (nblocks .ne. nblocks_id) call mpp_error(FATAL, "The size of your block_ids array is not correct") + + if (.not. present(parent_block_id)) then + call get_block_ids_all(file_id, trim(block_name)//c_null_char, block_ids) + else + if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, "The parent_block id in your get_block_ids call is invalid! Check your call.") + call get_block_ids_child(file_id, trim(block_name)//c_null_char, block_ids, parent_block_id) + endif +end subroutine get_block_ids + +!> @brief Gets the number of key-value pairs in a block +!! @return Number of key-value pairs in this block +function get_nkeys(file_id, block_id) & + result(nkeys) + integer, intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer, intent(in) :: block_id !< Id of the parent_block + integer :: nkeys + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_nkeys call is invalid! Check your call.") + if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, "The block id in your get_nkeys call is invalid! Check your call.") + + nkeys = get_nkeys_binding(file_id, block_id) +end function get_nkeys + +!> @brief Gets the ids of the key-value pairs in a block +subroutine get_key_ids (file_id, block_id, key_ids) + integer, intent(in) :: file_id !< File id corresponding to the yaml file that was opened + integer, intent(in) :: block_id !< Id of the parent_block + integer, intent(inout) :: key_ids(:) !< Ids of the key-value pairs + + integer :: nkey_ids !< Size of key_ids + integer :: nkeys !< Actual number of keys + + if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, "The file id in your get_key_ids call is invalid! Check your call.") + if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, "The block id in your get_key_ids call is invalid! Check your call.") + + nkey_ids = size(key_ids) + nkeys = get_nkeys(file_id, block_id) + + if (nkeys .ne. nkey_ids) call mpp_error(FATAL, "The size of your key_ids array is not correct.") + + call get_key_ids_binding (file_id, block_id, key_ids) +end subroutine get_key_ids + +#endif +end module yaml_parser_mod +!> @} +! close documentation grouping diff --git a/parser/yaml_parser_binding.c b/parser/yaml_parser_binding.c new file mode 100644 index 000000000..9c4fdaefa --- /dev/null +++ b/parser/yaml_parser_binding.c @@ -0,0 +1,342 @@ +/*********************************************************************** + * 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 . + **********************************************************************/ + +#ifdef use_yaml + +#include +#include +#include + +/* Type to store info about key */ +typedef struct { + int key_number; /* Id of this key */ + char key[255]; /* Name of the key */ + char value[255]; /* Value of the key */ + char parent_name[255]; /* Name of the block the key belongs to */ + int parent_key; /* Id of the block the key belongs to */ +}key_value_pairs; + +/* Type to store all of the keys */ +typedef struct { + int nkeys; + key_value_pairs *keys; +}yaml_file; + +/* Type to store all the yaml files that are opened */ +typedef struct { + yaml_file *files; +}file_type; + +file_type my_files; /* Array of opened yaml files */ +int nfiles = 0; /* Number of files in the yaml file */ + +/* @brief Private c function that gets the number of key-value pairs in a block + @return Number of key-value pairs in this block */ +int get_nkeys_binding(int *file_id, int *block_id) +{ + int nkeys = 0; /* Number of key-value pairs */ + int i; /* For loops */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(my_files.files[j].keys[i].parent_key == *block_id && !strcmp(my_files.files[j].keys[i].parent_name, "") ) nkeys = nkeys + 1; + } + + return nkeys; + +} + +/* @brief Private c function that gets the ids of the key-value pairs in a block */ +void get_key_ids_binding(int *file_id, int *block_id, int *key_ids) +{ + int i; /* For loops */ + int key_count = -1; /* Number of key-value pairs */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(my_files.files[j].keys[i].parent_key == *block_id && !strcmp(my_files.files[j].keys[i].parent_name, "") ){ + key_count = key_count + 1; + key_ids[key_count] = i; + } + } + + return; +} + +/* @brief Private c function that get the key from a key_id in a yaml file + @return Name of the key obtained */ +char *get_key(int *file_id, int *key_id) +{ + int j = *file_id; /* To minimize the typing :) */ + return my_files.files[j].keys[*key_id].key; +} + +/* @brief Private c function that get the value from a key_id in a yaml file + @return String containing the value obtained */ +char *get_value(int *file_id, int *key_id) +{ + int j = *file_id; /* To minimize the typing :) */ + return my_files.files[j].keys[*key_id].value; +} + +/* @brief Private c function that determines they value of a key in yaml_file + @return c pointer with the value obtained */ +char *get_value_from_key_wrap(int *file_id, int *block_id, char *key_name, int *sucess) /*, char *key_name) */ +{ + int i; /* For loops */ + int j = *file_id; /* To minimize the typing :) */ + + *sucess = 0; /* Flag indicating if the search was sucessful */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if (my_files.files[j].keys[i].parent_key == *block_id) + { + if( strcmp(my_files.files[j].keys[i].key, key_name) == 0) + { + *sucess = 1; + break; + } + } + } + if (*sucess == 1) {return my_files.files[j].keys[i].value;} else {return "";} +} + +/* @brief Private c function that determines the number of blocks with block_name in the yaml file + @return Number of blocks with block_name */ +int get_num_blocks_all(int *file_id, char *block_name) +{ + int nblocks = 0; /* Number of blocks */ + int i; /* For loops */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(strcmp(my_files.files[j].keys[i].parent_name, block_name) == 0) nblocks = nblocks + 1; + } + + return nblocks; +} + +/* @brief Private c function that determines the number of blocks with block_name that belong to + a parent block with parent_block_id in the yaml file + @return Number of blocks with block_name */ +int get_num_blocks_child(int *file_id, char *block_name, int *parent_block_id) +{ + int nblocks = 0; /* Number of blocks */ + int i; /* For loops */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(strcmp(my_files.files[j].keys[i].parent_name, block_name) == 0 && my_files.files[j].keys[i].parent_key == *parent_block_id) nblocks = nblocks + 1; + } + + return nblocks; +} + + +/* @brief Private c function that gets the the ids of the blocks with block_name in the yaml file */ +void get_block_ids_all(int *file_id, char *block_name, int *block_ids) +{ + int i; /* For loops */ + int nblocks = -1; /* Number of blocks */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(strcmp(my_files.files[j].keys[i].parent_name, block_name) == 0) { + nblocks = nblocks + 1; + block_ids[nblocks] = my_files.files[j].keys[i].key_number; + } + } + return; +} + +/* @brief Private c function that gets the the ids of the blocks with block_name and that + belong to a parent block id in the yaml file */ +void get_block_ids_child(int *file_id, char *block_name, int *block_ids, int *parent_key_id ) +{ + int i; /* For loops */ + int nblocks = -1; /* Number of blocks */ + int j = *file_id; /* To minimize the typing :) */ + + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) + { + if(strcmp(my_files.files[j].keys[i].parent_name, block_name) == 0 && my_files.files[j].keys[i].parent_key == *parent_key_id) { + nblocks = nblocks + 1; + block_ids[nblocks] = my_files.files[j].keys[i].key_number; + } + } + return; +} + +/* @brief Private c function to determine if a block_id is valid */ +bool is_valid_block_id(int *file_id, int *block_id) +{ + /* If the block id it not in the allowed range is not a valid block id */ + if (*block_id <= -1 || *block_id > my_files.files[*file_id].nkeys) {return false;} + + /* If the block id has an empty parent name then it is not a valid block id */ + if (*block_id != 0 && strcmp(my_files.files[*file_id].keys[*block_id].parent_name, "") == 0) {return false;} + return true; +} + +/* @brief Private c function to determine if a key_id is valid */ +bool is_valid_key_id(int *file_id, int *key_id) +{ + if (*key_id > -1 && *key_id <= my_files.files[*file_id].nkeys) {return true;} + else { return false;} +} + +/* @brief Private c function to determine if a file_id is valid */ +bool is_valid_file_id(int *file_id) +{ + if (*file_id > -1 && *file_id < nfiles) {return true;} + else { return false;} +} + +/* @brief Private c function that opens and parses a yaml file and saves it in a struct + @return Flag indicating if the read was sucessful */ +bool open_and_parse_file_wrap(char *filename, int *file_id) +{ + yaml_parser_t parser; + yaml_token_t token; + FILE *file; + + bool is_key = false; /* Flag indicating if the current token in a key */ + char key_value[255]; /* Value of a key */ + int layer = 0; /* Current layer (block level) */ + int key_count=0; /* Current number of keys */ + int parent[10]; /* Ids of blocks */ + int current_parent; /* Id of the current block */ + char layer_name[10][255]; /* Array of block names */ + char current_layername[255]; /* Name of the current block */ + int i; /* To minimize the typing :) */ + int j; /* To minimize the typing :) */ + + if (nfiles == 0 ) + { + my_files.files = (yaml_file*)calloc(1, sizeof(yaml_file)); + } else + { + my_files.files = realloc(my_files.files, (nfiles+1)*sizeof(yaml_file)); + } + + j = nfiles; + *file_id =j; + +/* printf("Opening file: %s.\nThere are %i files opened.\n", filename, j); */ + file = fopen(filename, "r"); + if (file == NULL) return false; + + if(!yaml_parser_initialize(&parser)) return false; + + my_files.files[j].keys = (key_value_pairs*)calloc(1, sizeof(key_value_pairs)); + + parent[0]=0; + strcpy(layer_name[0], "TOP"); + /* Set input file */ + yaml_parser_set_input_file(&parser, file); + do { + yaml_parser_scan(&parser, &token); + switch(token.type) + { + case YAML_KEY_TOKEN: + { + is_key = true; + break; + } + case YAML_VALUE_TOKEN: + { + is_key = false; + break; + } + case YAML_BLOCK_ENTRY_TOKEN: + { + layer = layer + 1; + + if (strcmp(key_value, "")) + { + strcpy(layer_name[layer], key_value); + } + key_count = key_count + 1; + i = key_count; + my_files.files[j].keys = realloc(my_files.files[j].keys, (i+1)*sizeof(key_value_pairs)); + my_files.files[j].keys[i].key_number=i; + my_files.files[j].keys[i].parent_key = parent[layer-1]; + strcpy(my_files.files[j].keys[i].parent_name, layer_name[layer]); + strcpy(my_files.files[j].keys[i].key, ""); + strcpy(my_files.files[j].keys[i].value, ""); + parent[layer]=key_count; + /*printf("KEY:%i LAYER:%i NAME:%s for %s=%i\n", key_count, layer, layer_name[layer], layer_name[layer-1], parent[layer-1]); */ + + break; + } + case YAML_BLOCK_END_TOKEN: + { + layer = layer - 1; + break; + } + case YAML_SCALAR_TOKEN: + { + if ( ! is_key) + { + current_parent = parent[layer]; + strcpy(current_layername, ""); + key_count = key_count + 1; + i = key_count; + my_files.files[j].keys = realloc(my_files.files[j].keys, (i+1)*sizeof(key_value_pairs)); + my_files.files[j].keys[i].key_number=i; + my_files.files[j].keys[i].parent_key = current_parent; + strcpy(my_files.files[j].keys[i].parent_name, current_layername); + strcpy(my_files.files[j].keys[i].key, key_value); + strcpy(my_files.files[j].keys[i].value, token.data.scalar.value); + my_files.files[j].nkeys = key_count; + /* printf("----> LAYER:%i LAYER_NAME=%s PARENT:%i, KEYCOUNT:%i KEY: %s VALUE: %s \n", layer, current_layername, current_parent, key_count, key_value, token.data.scalar.value); */ + strcpy(key_value,""); + } + else + {strcpy(key_value,token.data.scalar.value);} + } + break; + } + if(token.type != YAML_STREAM_END_TOKEN) + yaml_token_delete(&token); + } while(token.type != YAML_STREAM_END_TOKEN); + yaml_token_delete(&token); + yaml_parser_delete(&parser); + + /* + for ( i = 1; i <= my_files.files[j].nkeys; i++ ) { + printf("Key_number:%i Parent_key:%i Parent_name:%s Key:%s Value:%s \n", my_files.files[j].keys[i].key_number, my_files.files[j].keys[i].parent_key, my_files.files[j].keys[i].parent_name, my_files.files[j].keys[i].key, my_files.files[j].keys[i].value); + } + printf("/\n"); + */ + + nfiles = nfiles + 1; +/* printf("closing file: %s\n", filename); */ + fclose(file); + + return true; +} + +#endif diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 9e070def2..639a69c5b 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -26,7 +26,7 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic interpolator fms mpp mpp_io time_interp time_manager \ -horiz_interp field_manager axis_utils affinity fms2_io +horiz_interp field_manager axis_utils affinity fms2_io parser # This input file must be distributed, it is turned into # test_common.sh by configure. diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index 252533e24..7564bec26 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -44,4 +44,4 @@ EXTRA_DIST = input_base.nml diag_table_base data_table_base \ test_data_override2.sh # Clean up -CLEANFILES = input.nml *.nc* *.out diag_table data_table +CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml diff --git a/test_fms/data_override/test_data_override2.sh b/test_fms/data_override/test_data_override2.sh index 873b97d68..785c14a49 100755 --- a/test_fms/data_override/test_data_override2.sh +++ b/test_fms/data_override/test_data_override2.sh @@ -30,18 +30,31 @@ # Run the ongrid test case with 2 halos in x and y touch input.nml +cat <<_EOF > data_table.yaml +data_table: + - gridname : "OCN" + fieldname_code : "runoff" + fieldname_file : "runoff" + file_name : "INPUT/runoff.daitren.clim.1440x1080.v20180328.nc" + interpol_method : "none" + factor : 1.0 +_EOF + printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0' | cat > data_table [ ! -d "INPUT" ] && mkdir -p "INPUT" +echo "TEST 1" run_test test_data_override_ongrid 6 rm -rf "INPUT" # Run the ongrid test case again with no halos printf "&test_data_override_ongrid_nml \n nhalox=0 \n nhaloy=0\n/" | cat > input.nml [ ! -d "INPUT" ] && mkdir -p "INPUT" +echo "TEST 2" run_test test_data_override_ongrid 6 rm -rf "INPUT" # Run the get_grid_v1 test: +echo "TEST 3" run_test test_get_grid_v1 1 # Copy to builddir and rename data files for tests. diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index 86a76700a..9794d5bda 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -479,6 +479,7 @@ PROGRAM test ALLOCATE(dat1(is1:ie1,js1:je1,nlev)) ALLOCATE(dat1h(is1-hi:ie1+hi,js1-hj:je1+hj,nlev)) dat1h = 0. + dat1 = 0. DO j=js1, je1 DO i=is1, ie1 dat1(i,j,1) = SIN(lon1(i))*COS(lat1(j)) diff --git a/test_fms/diag_manager/test_diag_manager_time.F90 b/test_fms/diag_manager/test_diag_manager_time.F90 index 03419ab44..78e540951 100644 --- a/test_fms/diag_manager/test_diag_manager_time.F90 +++ b/test_fms/diag_manager/test_diag_manager_time.F90 @@ -83,11 +83,6 @@ program test_diag_manager_time id_sst = register_diag_field ('test_diag_manager_mod', 'sst', (/id_x,id_y,id_z/), Time, 'SST', 'K') id_ice = register_diag_field ('test_diag_manager_mod', 'ice', (/id_x,id_y/), Time, 'ICE', 'm') -! Send the axis data -used = send_data(id_x, x, Time) -used = send_data(id_y, y, Time) -used = send_data(id_z, z, Time) - ! Increase the time and send data do i=1,23 Time = set_date(2,1,1,i,0,0) diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index 387441f92..bdb3d39e7 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -14,13 +14,14 @@ program test_fms use mpp_mod, only : mpp_error, fatal, note, mpp_init use fms_mod, only : fms_init, string, fms_end use fms_mod, only : fms_c2f_string + use fms_mod, only : fms_cstring2cpointer use test_fms_mod use, intrinsic :: iso_c_binding integer :: i !< Integer character(len=16) :: answer !< expected answer character(len=16) :: test !< Test string - character(len=:,kind=c_char), pointer :: Cstring !< C string to convert + character(kind=c_char) :: Cstring (17)!< C string to convert type(c_ptr), pointer :: Cptr !< C pointer to string call mpp_init() @@ -50,6 +51,26 @@ program test_fms else call mpp_error(FATAL, trim(test)//" does not match "//trim(answer)) endif +!!!!!!!!!!!!!!!!!!!! +! Test the c string to c pointer conversion + test = " " + answer = '100' + Cstring = " " + Cstring(1) = "1" + Cstring(2) = "0" + Cstring(3) = "0" + Cstring(17) = c_null_char + call mpp_error(NOTE,"Testing fms_cstring2cpointer and fms_c2f_string") +! test = fms_c2f_string(fms_cstring2cpointer(c_char_"100 "//c_null_char)) + test = fms_c2f_string(fms_cstring2cpointer(Cstring)) + if (trim(answer) .eq. trim(test)) then + call mpp_error(NOTE, trim(test)//" matches "//trim(answer)) + else + call mpp_error(FATAL, trim(test)//" does not match "//trim(answer)) + endif + + + call fms_end() diff --git a/test_fms/parser/Makefile.am b/test_fms/parser/Makefile.am new file mode 100644 index 000000000..469538ce1 --- /dev/null +++ b/test_fms/parser/Makefile.am @@ -0,0 +1,54 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the test_fms/data_override directory of the FMS +# package. + +# uramirez, Ed Hartnett + +# Find the needed mod and .inc files. +AM_CPPFLAGS = -I${top_srcdir}/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = ${top_builddir}/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = parser_demo2 test_yaml_parser check_crashes parser_demo + +# This is the source code for the test. +test_yaml_parser_SOURCES = test_yaml_parser.F90 +check_crashes_SOURCES = check_crashes.F90 +parser_demo_SOURCES = parser_demo.F90 +parser_demo2_SOURCES = parser_demo2.F90 + +# Run the test program. +TESTS = test_yaml_parser.sh + +# Include these files with the distribution. +EXTRA_DIST = test_yaml_parser.sh + +if SKIP_PARSER_TESTS +skipflag="skip" +else +skipflag="" +endif + +TESTS_ENVIRONMENT = parser_skip=${skipflag} +# Clean up +CLEANFILES = input.nml *.nc* *.out *.yaml diff --git a/test_fms/parser/check_crashes.F90 b/test_fms/parser/check_crashes.F90 new file mode 100644 index 000000000..d454ed6cf --- /dev/null +++ b/test_fms/parser/check_crashes.F90 @@ -0,0 +1,255 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +program check_crashes +!> @brief This programs tests if the public subroutines in parser/yaml_parser.F90 +!! crash as expected +#ifdef use_yaml +use yaml_parser_mod +use mpp_mod +use fms_mod, only : fms_init, fms_end + +implicit none + +integer :: io_status !< io_status when reading a namelist +logical :: missing_file = .false. !< try to open files that do not exist +logical :: bad_conversion = .false. !< try type conversions that are not possible +logical :: missing_key = .false. !< try to get the value of a key that does not exist +logical :: wrong_buffer_size_key_id = .false. !< try to send an array of key_id that is the wrong size +logical :: wrong_buffer_size_block_id = .false. !< try to send an array of block_id that is the wrong size +logical :: get_key_name_bad_key_id = .false. !< try to send a bad key_id to get_key_name +logical :: get_key_value_bad_key_id = .false. !< try to send a bad key_id to get_key_value +logical :: get_block_ids_bad_id = .false. !< try to send a bad file_id to get_block_ids +logical :: get_key_name_bad_id = .false. !< try to send a bad file_id to get_key_name +logical :: get_key_value_bad_id = .false. !< try to send a bad file_id to get_key_value +logical :: get_num_blocks_bad_id = .false. !< try to send a bad file_id to get_num_blocks +logical :: get_value_from_key_bad_id = .false. !< try to send a bad file_id to get_value_from_key +logical :: get_nkeys_bad_id = .false. !< try to send a bad file_id to get_nkeys +logical :: get_key_ids_bad_id = .false. !< try to send a bad file_id to get_key_ids +logical :: get_key_ids_bad_block_id = .false. !< try to send a bad block_id to get_key_ids +logical :: get_nkeys_bad_block_id = .false. !< try to send a bad block_id to get_nkeys +logical :: get_block_ids_bad_block_id = .false. !< try to send a bad block_id to get_block_ids +logical :: get_num_blocks_bad_block_id = .false. !< try to send a bad block_id to get_num_blocks +logical :: get_value_from_key_bad_block_id = .false. !< try to send a bad block_id to get_value_from_key + +namelist / check_crashes_nml / missing_file, bad_conversion, missing_key, get_block_ids_bad_id, & + get_key_name_bad_id, get_key_value_bad_id, get_num_blocks_bad_id, get_value_from_key_bad_id, & + get_nkeys_bad_id, get_key_ids_bad_id, & + get_key_name_bad_key_id, get_key_value_bad_key_id, & + get_key_ids_bad_block_id, get_nkeys_bad_block_id, get_block_ids_bad_block_id, get_num_blocks_bad_block_id, & + get_value_from_key_bad_block_id, & + wrong_buffer_size_key_id, wrong_buffer_size_block_id + +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') + +if (missing_file) call check_read_and_parse_file_missing +if (get_block_ids_bad_id) call check_get_block_ids_bad_id +if (get_key_name_bad_id) call check_get_key_name_bad_id +if (get_key_value_bad_id) call check_get_key_value_bad_id +if (get_num_blocks_bad_id) call check_get_num_blocks_bad_id +if (get_value_from_key_bad_id) call check_get_value_from_key_bad_id +if (get_nkeys_bad_id) call check_get_nkeys_bad_id +if (get_key_ids_bad_id) call check_get_key_ids_bad_id +if (bad_conversion) call check_bad_conversion +if (missing_key) call check_missing_key +if (wrong_buffer_size_key_id) call check_wrong_buffer_size_key_id +if (wrong_buffer_size_block_id) call check_wrong_buffer_size_block_id +if (get_key_name_bad_key_id) call check_get_key_name_bad_key_id +if (get_key_value_bad_key_id) call check_get_key_value_bad_key_id +if (get_key_ids_bad_block_id) call check_get_key_ids_bad_block_id +if (get_nkeys_bad_block_id) call check_get_nkeys_bad_block_id +if (get_block_ids_bad_block_id) call check_get_block_ids_bad_block_id +if (get_num_blocks_bad_block_id) call check_get_num_blocks_bad_block_id +if (get_value_from_key_bad_block_id) call check_get_value_from_key_bad_block_id + +call fms_end + +contains +!> @brief This is to check if the parser crashes correctly if user sends a bad block_id to get_key_ids +subroutine check_get_key_ids_bad_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: key_ids(10) !< array of key ids + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_key_ids (yaml_file_id, -40, key_ids) + +end subroutine check_get_key_ids_bad_block_id + +!> @brief This is to check if the parser crashes correctly if user sends a bad block_id to get_nkeys +subroutine check_get_nkeys_bad_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: nkeys !< number of keys + + yaml_file_id = open_and_parse_file("diag_table.yaml") + nkeys = get_nkeys(yaml_file_id, 9999) + +end subroutine check_get_nkeys_bad_block_id + +!> @brief This is to check if the parser crashes correctly if user sends a bad parent_block_id to get_block_ids +subroutine check_get_block_ids_bad_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: block_ids(10)!< array of block ids + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_block_ids(yaml_file_id, "varList", block_ids, parent_block_id=-40) + +end subroutine check_get_block_ids_bad_block_id + +!> @brief This is to check if the parser crashes correctly if user sends a bad parent_block_id to get_num_blocks +subroutine check_get_num_blocks_bad_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: nblocks !< number of blocks + + yaml_file_id = open_and_parse_file("diag_table.yaml") + + nblocks = get_num_blocks(yaml_file_id, "varList", parent_block_id=-30) + +end subroutine check_get_num_blocks_bad_block_id + +!> @brief This is to check if the parser crashes correctly if user sends a bad parent_block_id to get_value_from_key +subroutine check_get_value_from_key_bad_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: key_value !< integer buffer + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_value_from_key(yaml_file_id, 999, "mullions", key_value) + +end subroutine check_get_value_from_key_bad_block_id + +!> @brief This is to check if the parser crashes correctly if user tries to open a missing file. +subroutine check_read_and_parse_file_missing + integer :: yaml_file_id !< file_id for a yaml file + + yaml_file_id = open_and_parse_file("missing") +end subroutine check_read_and_parse_file_missing + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_block_ids +subroutine check_get_block_ids_bad_id + integer :: block_ids(10) !< array of block ids + + call get_block_ids(-40, "diagFiles", block_ids) +end subroutine check_get_block_ids_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_key_name +subroutine check_get_key_name_bad_id + character(len=10) :: buffer !< string buffer + + call get_key_name(-45, 1, buffer) +end subroutine check_get_key_name_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_key_value +subroutine check_get_key_value_bad_id + character(len=10) :: buffer !< string buffer + + call get_key_value(-45, 1, buffer) +end subroutine check_get_key_value_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_num_blocks +subroutine check_get_num_blocks_bad_id + integer :: nblocks !< number of blocks + + nblocks = get_num_blocks(-45, "diagFiles") +end subroutine check_get_num_blocks_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_value_from_key +subroutine check_get_value_from_key_bad_id + character(len=10) :: string_buffer !< string buffer + + call get_value_from_key(-45, 1, "varName", string_buffer) +end subroutine check_get_value_from_key_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_nkeys +subroutine check_get_nkeys_bad_id + integer :: nkeys !< number of keys + + nkeys = get_nkeys(-45, 1) +end subroutine check_get_nkeys_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid file id to get_key_ids +subroutine check_get_key_ids_bad_id + integer :: key_ids(10) !< array of key ids + + call get_key_ids(-45, 1, key_ids) +end subroutine check_get_key_ids_bad_id + +!> @brief This is to check if the parser crashes correctly if user sends a buffer of the wrong type +subroutine check_bad_conversion + integer :: yaml_file_id !< file_id for a yaml file + real :: buffer !< real buffer + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_value_from_key(yaml_file_id, 9, "varName", buffer) +end subroutine check_bad_conversion + +!> @brief This is to check if the parser crashes correctly if user tries to get they value for a key +!! that doesn't exist +subroutine check_missing_key + integer :: yaml_file_id !< file_id for a yaml file + real :: buffer !< string bufffer + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_value_from_key(yaml_file_id, 9, "missing", buffer) +end subroutine check_missing_key + +!> @brief This is to check if the parser crashes correctly if user sends an invalid key id to get_key_name +subroutine check_get_key_name_bad_key_id + integer :: yaml_file_id !< file_id for a yaml file + character(len=10) :: buffer !< string buffer + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_key_name(yaml_file_id, 666, buffer) + +end subroutine check_get_key_name_bad_key_id + +!> @brief This is to check if the parser crashes correctly if user sends an invalid key id to get_key_value +subroutine check_get_key_value_bad_key_id + integer :: yaml_file_id !< file_id for a yaml file + character(len=10) :: buffer !< string buffer + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_key_value(yaml_file_id, 666, buffer) + +end subroutine check_get_key_value_bad_key_id + +!> @brief This is to check if the parser crashes correctly if user sends an a key_id array that is that the correct +!! size to get_key_ids +subroutine check_wrong_buffer_size_key_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: key_ids(1) !< array of key ids + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_key_ids(yaml_file_id, 19, key_ids) + +end subroutine check_wrong_buffer_size_key_id + +!> @brief This is to check if the parser crashes correctly if user sends an a block_id array that is that the correct +!! size to get_block_ids +subroutine check_wrong_buffer_size_block_id + integer :: yaml_file_id !< file_id for a yaml file + integer :: block_ids(10)!< array of block ids + + yaml_file_id = open_and_parse_file("diag_table.yaml") + call get_block_ids(yaml_file_id, "diag_files", block_ids) + +end subroutine check_wrong_buffer_size_block_id +#endif +end program check_crashes diff --git a/test_fms/parser/parser_demo.F90 b/test_fms/parser/parser_demo.F90 new file mode 100644 index 000000000..16bc1c81a --- /dev/null +++ b/test_fms/parser/parser_demo.F90 @@ -0,0 +1,119 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +program parser_demo +!> @brief This programs demostrates how to use the parser + +#ifdef use_yaml +use FMS_mod, only: fms_init, fms_end +use yaml_parser_mod +use platform_mod + +implicit none + +integer :: diag_yaml_id !< Id for the diag_table yaml +integer :: nfiles !< Number of files in the diag_table yaml +integer, allocatable :: file_ids(:) !< Ids of the files in the diag_table yaml +integer :: nvariables !< Number of variables in the diag_table yaml +integer, allocatable :: var_ids(:) !< Ids of the variables in the diag_table yaml +integer :: i, j !< For do loops +character(len=255) :: string_buffer !< Buffer to read strings to +integer :: int_buffer !< Buffer to read integers to +real(kind=r8_kind) :: r8_buffer !< Buffer to read r8 to + +call fms_init +call fms_end + +diag_yaml_id = open_and_parse_file("diag_table.yaml") +print *, "" + +call get_value_from_key(diag_yaml_id, 0, "title", string_buffer) +print *, "title:", trim(string_buffer) + +call get_value_from_key(diag_yaml_id, 0, "baseDate", string_buffer) +print *, "baseDate:", trim(string_buffer) + +nfiles = get_num_blocks(diag_yaml_id, "diag_files") +allocate(file_ids(nfiles)) +call get_block_ids(diag_yaml_id, "diag_files", file_ids) +print *, "" + +do i = 1, nfiles + print *, "File number:", i + + call get_value_from_key(diag_yaml_id, file_ids(i), "fileName", string_buffer) + print *, "fileName:", trim(string_buffer) + + call get_value_from_key(diag_yaml_id, file_ids(i), "freq", int_buffer) + print *, "freq:", int_buffer + + call get_value_from_key(diag_yaml_id, file_ids(i), "frequnit", string_buffer) + print *, "frequnit:", trim(string_buffer) + + call get_value_from_key(diag_yaml_id, file_ids(i), "timeunit", string_buffer) + print *, "timeunit:", trim(string_buffer) + + call get_value_from_key(diag_yaml_id, file_ids(i), "unlimdim", string_buffer) + print *, "unlimdim:", trim(string_buffer) + + !< The number of variables that are part of the current file + nvariables = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=file_ids(i)) + allocate(var_ids(nvariables)) + call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=file_ids(i)) + + do j = 1, nvariables + print *, " Variable number:", j + + call get_value_from_key(diag_yaml_id, var_ids(j), "varName", string_buffer) + print *, " varName:", trim(string_buffer) + + string_buffer = "" + call get_value_from_key(diag_yaml_id, var_ids(j), "reduction", string_buffer) + print *, " reduction:", trim(string_buffer) + + string_buffer = "" + call get_value_from_key(diag_yaml_id, var_ids(j), "module", string_buffer) + print *, " module:", trim(string_buffer) + + r8_buffer = 0. + call get_value_from_key(diag_yaml_id, var_ids(j), "fill_value", r8_buffer, is_optional=.true.) + print *, " fill_value:", r8_buffer + + string_buffer = "" + call get_value_from_key(diag_yaml_id, var_ids(j), "outName", string_buffer, is_optional=.true.) + print *, " outName:", trim(string_buffer) + + string_buffer = "" + call get_value_from_key(diag_yaml_id, var_ids(j), "kind", string_buffer, is_optional=.true.) + print *, " kind:", trim(string_buffer) + + int_buffer = 0. + call get_value_from_key(diag_yaml_id, var_ids(j), "mullions", int_buffer, is_optional=.true.) + print *, " mullions:", int_buffer + + print *, "" + end do + deallocate(var_ids) + print *, "" +enddo +deallocate(file_ids) + +#endif + +end program parser_demo diff --git a/test_fms/parser/parser_demo2.F90 b/test_fms/parser/parser_demo2.F90 new file mode 100644 index 000000000..c230559a4 --- /dev/null +++ b/test_fms/parser/parser_demo2.F90 @@ -0,0 +1,108 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +program parser_demo +!> @brief This programs demostrates how to use the parser + +#ifdef use_yaml +use FMS_mod, only: fms_init, fms_end +use yaml_parser_mod +use platform_mod + +implicit none + +integer :: diag_yaml_id !< Id for the diag_table yaml +integer :: nfiles !< Number of files in the diag_table yaml +integer, allocatable :: file_ids(:) !< Ids of the files in the diag_table yaml +integer :: nvariables !< Number of variables in the diag_table yaml +integer, allocatable :: var_ids(:) !< Ids of the variables in the diag_table yaml +integer :: i, j, k !< For do loops +integer :: nkeys !< Number of keys +integer, allocatable :: key_ids(:) !< Ids of keys in the diag_table_yaml +character(len=255) :: key_value !< The value of a key +character(len=255) :: key_name !< The name of a key + +call fms_init +call fms_end + +diag_yaml_id = open_and_parse_file("diag_table.yaml") +print *, "" + +nkeys = get_nkeys(diag_yaml_id, 0) +allocate(key_ids(nkeys)) +call get_key_ids(diag_yaml_id, 0, key_ids) + +do i = 1, nkeys + call get_key_name(diag_yaml_id, key_ids(i), key_name) + call get_key_value(diag_yaml_id, key_ids(i), key_value) + print *, "Key:", trim(key_name), " Value:", trim(key_value) +enddo + +deallocate(key_ids) + +nfiles = get_num_blocks(diag_yaml_id, "diag_files") +allocate(file_ids(nfiles)) +call get_block_ids(diag_yaml_id, "diag_files", file_ids) +print *, "" + +do i = 1, nfiles + print *, "File number:", i + + nkeys = get_nkeys(diag_yaml_id, file_ids(i)) + allocate(key_ids(nkeys)) + call get_key_ids(diag_yaml_id, file_ids(i), key_ids) + + do j = 1, nkeys + call get_key_name(diag_yaml_id, key_ids(j), key_name) + call get_key_value(diag_yaml_id, key_ids(j), key_value) + print *, " Key:", trim(key_name), " Value:", trim(key_value) + enddo + + deallocate(key_ids) + print *, "" + !< The number of variables that are part of the current file + nvariables = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=file_ids(i)) + allocate(var_ids(nvariables)) + call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=file_ids(i)) + + do j = 1, nvariables + print *, " Variable number:", j + + nkeys = get_nkeys(diag_yaml_id, var_ids(j)) + allocate(key_ids(nkeys)) + call get_key_ids(diag_yaml_id, var_ids(j), key_ids) + + do k = 1, nkeys + call get_key_name(diag_yaml_id, key_ids(k), key_name) + call get_key_value(diag_yaml_id, key_ids(k), key_value) + print *, " Key:", trim(key_name), " Value:", trim(key_value) + enddo + + deallocate(key_ids) + print *, "" + end do + + deallocate(var_ids) + print *, "" +enddo +deallocate(file_ids) + +#endif + +end program parser_demo diff --git a/test_fms/parser/test_yaml_parser.F90 b/test_fms/parser/test_yaml_parser.F90 new file mode 100644 index 000000000..3cdc3b7fb --- /dev/null +++ b/test_fms/parser/test_yaml_parser.F90 @@ -0,0 +1,155 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This programs tests the public subroutines in parser/yaml_parser.F90 +program test_read_and_parse_file + +#ifdef use_yaml +use yaml_parser_mod +use mpp_mod +use fms_mod, only : fms_init, fms_end +use platform_mod + +implicit none + +integer :: yaml_file_id1 !< file id of a yaml file +integer :: nfiles !< number of files +integer :: nvariables !< number of variables +integer, allocatable :: file_ids(:) !< array of file ids +integer, allocatable :: variable_ids(:) !< array of variable ids +integer :: yaml_file_id2 !< file id of a yaml file +integer :: nentries !< number of entries +integer, allocatable :: entries_ids(:) !< array of entries ids +integer :: zero !< dummy integer buffer +character(len=20) :: string_buffer !< string buffer +integer(kind=i4_kind) :: i4_buffer !< i4 buffer +integer(kind=i8_kind) :: i8_buffer !< i8 buffer +real(kind=r4_kind) :: r4_buffer !< r4 buffer +real(kind=r8_kind) :: r8_buffer !< r8 buffer +integer :: nkeys !< number of keys +integer, allocatable :: key_ids(:) !< array of key ids +character(len=20) :: key_name !< the name of the key +character(len=20) :: key_value !< the value of a key + +call fms_init + +!< Test open_and_parse_file +yaml_file_id1 = open_and_parse_file("diag_table.yaml") +if (yaml_file_id1 .ne. 0) call mpp_error(FATAL, "The yaml_file_id for this file should be 0") + +!< Test if multiple files can be opened +yaml_file_id2 = open_and_parse_file("data_table.yaml") +if (yaml_file_id2 .ne. 1) call mpp_error(FATAL, "The yaml_file_id for this file should be 1") + +!< ----------------------------------- + +!< Test get_num_blocks +nfiles = get_num_blocks(yaml_file_id1, "diag_files") +if (nfiles .ne. 2) call mpp_error(FATAL, "There should be only 2 diag_files") + +!< Test if a different yaml file id will work +nentries = get_num_blocks(yaml_file_id2, "data_table") +if (nentries .ne. 2) call mpp_error(FATAL, "There should be only 2 entries") + +!< Try to look for a block that does not exist! +zero = get_num_blocks(yaml_file_id2, "diag_files") +if (zero .ne. 0) call mpp_error(FATAL, "'diag_files' should not exist in this file") + +!< Try the parent block_id optional argument +nvariables = get_num_blocks(yaml_file_id1, "varlist", parent_block_id=3) !< Number of variables that belong to the atmos_daily file in the diag_table.yaml +if (nvariables .ne. 2) call mpp_error(FATAL, "There should only be 2 variables in the atmos_daily file") + +!< ----------------------------------- + +!< Test get_block_ids +allocate(file_ids(nfiles)) +call get_block_ids(yaml_file_id1, "diag_files", file_ids) +if(file_ids(1) .ne. 3 .or. file_ids(2) .ne. 21) call mpp_error(FATAL, "The file_ids are wrong!") + +!< Test to see if a diffrent yaml file id will work +allocate(entries_ids(nentries)) +call get_block_ids(yaml_file_id2, "data_table", entries_ids) +if(entries_ids(1) .ne. 1 .or. entries_ids(2) .ne. 8) call mpp_error(FATAL, "The entry_ids are wrong!") + +!< Try the parent block id optional argument +allocate(variable_ids(nvariables)) +call get_block_ids(yaml_file_id1, "varlist", variable_ids, parent_block_id=3) +if (variable_ids(1) .ne. 9 .or. variable_ids(2) .ne. 15) call mpp_error(FATAL, "The variable_ids are wrong!") + +!< Error check: *_ids is not the correct size + +!< ----------------------------------- + +!< Test get_value_from_key +!! Try get_value_from_key using a string buffer +call get_value_from_key(yaml_file_id1, variable_ids(1), "varName", string_buffer) +if (trim(string_buffer) .ne. "tdata") call mpp_error(FATAL, "varName was not read correctly!") + +!! Try get_value_from_key using a i4 buffer +call get_value_from_key(yaml_file_id1, variable_ids(1), "mullions", i4_buffer) +if (i4_buffer .ne. int(10, kind=i4_kind)) call mpp_error(FATAL, "mullions was not read correctly as an i4!") + +!! Try get_value_from_key using a i8 buffer +call get_value_from_key(yaml_file_id1, variable_ids(1), "mullions", i8_buffer) +if (i8_buffer .ne. int(10, kind=i8_kind)) call mpp_error(FATAL, "mullions was not read correctly as an i8!") + +!! Try get_value_from_key using a r4 buffer +call get_value_from_key(yaml_file_id1, variable_ids(1), "fill_value", r4_buffer) +if (r4_buffer .ne. real(-999.9, kind=r4_kind)) call mpp_error(FATAL, "fill_value was not read correctly as an r4!") + +!! Try get_value_from_key using a r8 buffer +call get_value_from_key(yaml_file_id1, variable_ids(1), "fill_value", r8_buffer) +if (r8_buffer .ne. real(-999.9, kind=r8_kind)) call mpp_error(FATAL, "fill_value was not read correctly as an r8!") + +!! Try the is_optional argument on an key that does not exist +string_buffer = "" +call get_value_from_key(yaml_file_id1, variable_ids(1), "NANANANA", string_buffer, is_optional=.true.) +if (trim(string_buffer) .ne. "") call mpp_error(FATAL, "string_buffer was set when they key does not exist?") + +!< ----------------------------------- + +!< Test nkeys +nkeys = get_nkeys(yaml_file_id1, variable_ids(1)) +if (nkeys .ne. 5) call mpp_error(FATAL, "The number of keys was not read correctly") + +!< ----------------------------------- + +!< Test get_key_ids +allocate(key_ids(nkeys)) +call get_key_ids(yaml_file_id1, variable_ids(1), key_ids) +if (key_ids(1) .ne. 10 .or. key_ids(2) .ne. 11 .or. key_ids(3) .ne. 12 .or. key_ids(4) .ne. 13 .or. key_ids(5) .ne. 14) call mpp_error(FATAL, "The key ids obtained are wrong") + +!< ----------------------------------- + +!< Test get_key_name +call get_key_name(yaml_file_id1, key_ids(1), key_name) +if ((trim(key_name) .ne. "varName")) call mpp_error(FATAL, "get_key_name did not output the correct name") + +!< Test get_key_value +call get_key_value(yaml_file_id1, key_ids(1), key_value) +if ((trim(key_value) .ne. "tdata")) call mpp_error(FATAL, "get_key_name did not output the correct name") + +deallocate(key_ids) +deallocate(variable_ids) +deallocate(entries_ids) +deallocate(file_ids) + +call fms_end +#endif +end program diff --git a/test_fms/parser/test_yaml_parser.sh b/test_fms/parser/test_yaml_parser.sh new file mode 100755 index 000000000..de134653d --- /dev/null +++ b/test_fms/parser/test_yaml_parser.sh @@ -0,0 +1,218 @@ +#!/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/parser directory. + +# Set common test settings. +. ../test_common.sh + +touch input.nml + +cat <<_EOF > data_table.yaml +data_table: + - gridname : "ICE" + fieldname_code : "sic_obs" + fieldname_file : "ice" + file_name : "INPUT/hadisst_ice.data.nc" + interpol_method : "bilinear" + factor : 0.01 + - gridname : "WUT" + fieldname_code : "potato" + fieldname_file : "mullions" + file_name : "INPUT/potato.nc" + interpol_method : "bilinear" + factor : 1e-06 + region_type : "inside_region" + lat_start : -89.1 + lat_end : 89.8 + lon_start : 3.4 + lon_end : 154.4 +_EOF + +cat <<_EOF > diag_table.yaml +title: c384L49_esm5PIcontrol +baseDate: [1960 1 1 1 1 1 1] +diag_files: +- fileName: "atmos_daily" + freq: 24 + frequnit: hours + timeunit: days + unlimdim: time + varlist: + - varName: tdata + reduction: False + module: mullions + mullions: 10 + fill_value: -999.9 + - varName: pdata + outName: pressure + reduction: False + kind: double + module: "moist" +- fileName: atmos_8xdaily + freq: 3 + frequnit: hours + timeunit: days + unlimdim: time + varlist: + - varName: tdata + reduction: False + module: "moist" +_EOF + +run_test test_yaml_parser 1 $parser_skip +run_test parser_demo 1 $parser_skip +run_test parser_demo2 1 $parser_skip + +printf "&check_crashes_nml \n missing_file = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n bad_conversion = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n missing_key = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_block_ids_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_num_blocks_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_nkeys_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_key_ids_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_key_name_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_key_value_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_value_from_key_bad_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_key_name_bad_key_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_key_value_bad_key_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +### +printf "&check_crashes_nml \n get_key_ids_bad_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_nkeys_bad_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_block_ids_bad_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_num_blocks_bad_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n get_value_from_key_bad_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n wrong_buffer_size_key_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi + +printf "&check_crashes_nml \n wrong_buffer_size_block_id = .true. \n/" | cat > input.nml +run_test check_crashes 1 && echo "It worked?" +if [ $? -eq 0 ]; then + echo "The test should have failed" + exit 3 +fi