diff --git a/CMAKE_INSTRUCTIONS.md b/CMAKE_INSTRUCTIONS.md index d627f12fa1..7f4858c30a 100644 --- a/CMAKE_INSTRUCTIONS.md +++ b/CMAKE_INSTRUCTIONS.md @@ -50,17 +50,18 @@ make install ``` ### User configurable options: -By default, FMS is built without `OpenMP` and in `single precision (r4)` +By default, FMS is built without `OpenMP`, in `single precision (r4)` and delivered in static library files. The 64BIT and 32BIT precision options will build distinct libraries when enabled with the given default real size, libfms_r4 or libfms_r8. The following build options are available: ``` --DOPENMP "Build FMS with OpenMP support" DEFAULT: OFF --D32BIT "Build 32-bit (r4) FMS library" DEFAULT: ON --D64BIT "Build 64-bit (r8) FMS library" DEFAULT: OFF --DFPIC "Build with position independent code" DEFAULT: OFF +-DOPENMP "Build FMS with OpenMP support" DEFAULT: OFF +-D32BIT "Build 32-bit (r4) FMS library" DEFAULT: ON +-D64BIT "Build 64-bit (r8) FMS library" DEFAULT: OFF +-DFPIC "Build with position independent code" DEFAULT: OFF +-DSHARED_LIBS "Build shared/dynamic libraries" DEFAULT: OFF -DCONSTANTS "Build with constants parameter definitions" DEFAULT:GFDL OPTIONS:GFS|GEOS|GFDL -DINTERNAL_FILE_NML "Enable compiler definition -DINTERNAL_FILE_NML" DEFAULT: ON diff --git a/CMakeLists.txt b/CMakeLists.txt index 2ca5c652ae..b7e66e6057 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -52,10 +52,11 @@ endif() list(APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake) # Build options -option(OPENMP "Build FMS with OpenMP support" OFF) -option(32BIT "Build 32-bit (r4) FMS library" ON) -option(64BIT "Build 64-bit (r8) FMS library" OFF) -option(FPIC "Build with position independent code" OFF) +option(OPENMP "Build FMS with OpenMP support" OFF) +option(32BIT "Build 32-bit (r4) FMS library" ON) +option(64BIT "Build 64-bit (r8) FMS library" OFF) +option(FPIC "Build with position independent code" OFF) +option(SHARED_LIBS "Build shared/dynamic libraries" OFF) # Options for compiler definitions option(INTERNAL_FILE_NML "Enable compiler definition -DINTERNAL_FILE_NML" ON) @@ -360,8 +361,15 @@ foreach(kind ${kinds}) endif() # FMS (C + Fortran) - add_library(${libTgt} STATIC $ - $) + if (SHARED_LIBS) + message(STATUS "Shared library target: ${libTgt}") + add_library(${libTgt} SHARED $ + $) + else () + message(STATUS "Static library target: ${libTgt}") + add_library(${libTgt} STATIC $ + $) + endif () target_include_directories(${libTgt} PUBLIC $ @@ -397,7 +405,8 @@ foreach(kind ${kinds}) target_compile_definitions(${libTgt} PRIVATE "${fms_defs}") target_compile_definitions(${libTgt} PRIVATE "${${kind}_defs}") - target_link_libraries(${libTgt} PUBLIC NetCDF::NetCDF_Fortran + target_link_libraries(${libTgt} PUBLIC NetCDF::NetCDF_C + NetCDF::NetCDF_Fortran MPI::MPI_Fortran) if(OpenMP_Fortran_FOUND) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 98fe717e06..87ff746fc0 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -135,10 +135,11 @@ module amip_interp_mod NOTE, mpp_error, fms_error_handler use constants_mod, only: TFREEZE, pi -use platform_mod, only: r4_kind, r8_kind, i2_kind +use platform_mod, only: r4_kind, r8_kind, i2_kind, FMS_FILE_LEN use mpp_mod, only: input_nml_file use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, & get_dimension_size, fms2_io_read_data=>read_data +use netcdf, only: NF90_MAX_NAME implicit none private @@ -302,9 +303,8 @@ module amip_interp_mod ! ---- global unit & date ---- - integer, parameter :: maxc = 128 integer :: iunit - character(len=maxc) :: file_name_sst, file_name_ice + character(len=FMS_FILE_LEN) :: file_name_sst, file_name_ice type(FmsNetcdfFile_t), target :: fileobj_sst, fileobj_ice type (date_type) :: Curr_date = date_type( -99, -99, -99 ) diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc index 07034bc3f9..b675d047f8 100644 --- a/amip_interp/include/amip_interp.inc +++ b/amip_interp/include/amip_interp.inc @@ -46,7 +46,7 @@ subroutine GET_AMIP_SST_ (Time, Interp, sst, err_msg, lon_model, lat_model) integer, dimension(:), allocatable :: ryr, rmo, rdy character(len=30) :: time_unit real(FMS_AMIP_INTERP_KIND_), dimension(:), allocatable :: timeval - character(len=maxc) :: ncfilename + character(len=FMS_FILE_LEN) :: ncfilename type(FmsNetcdfFile_t) :: fileobj logical :: the_file_exists ! end add by JHC @@ -652,7 +652,8 @@ endif integer(I2_KIND) :: idat(mobs,nobs) integer :: nrecords, yr, mo, dy, ierr, k integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=maxc) :: ncfilename, ncfieldname + character(len=FMS_FILE_LEN) :: ncfilename + character(len=NF90_MAX_NAME) :: ncfieldname type(FmsNetcdfFile_t), pointer :: fileobj integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90 index b7a3eb6874..39bcc8bc69 100644 --- a/column_diagnostics/column_diagnostics.F90 +++ b/column_diagnostics/column_diagnostics.F90 @@ -32,7 +32,7 @@ module column_diagnostics_mod get_date, time_type use constants_mod, only: constants_init, PI, RADIAN use mpp_mod, only: input_nml_file -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_FILE_LEN !------------------------------------------------------------------- implicit none diff --git a/column_diagnostics/include/column_diagnostics.inc b/column_diagnostics/include/column_diagnostics.inc index c2e18f2a7d..8b79c72a6d 100644 --- a/column_diagnostics/include/column_diagnostics.inc +++ b/column_diagnostics/include/column_diagnostics.inc @@ -99,7 +99,7 @@ integer, dimension(:), intent(out) :: diag_units !< unit number for real(FMS_CD_KIND_) :: ref_lat real(FMS_CD_KIND_) :: current_distance character(len=8) :: char !< character string for diaganostic column index - character(len=32) :: filename !< filename for output file for diagnostic column + character(len=FMS_FILE_LEN) :: filename !< filename for output file for diagnostic column logical :: allow_ij_input logical :: open_file integer :: io diff --git a/coupler/atmos_ocean_fluxes.F90 b/coupler/atmos_ocean_fluxes.F90 index e15aec78bc..840b82f28b 100644 --- a/coupler/atmos_ocean_fluxes.F90 +++ b/coupler/atmos_ocean_fluxes.F90 @@ -48,7 +48,7 @@ module atmos_ocean_fluxes_mod use coupler_types_mod, only: ind_runoff use coupler_types_mod, only: ind_flux, ind_deltap, ind_kw, ind_flux0 - use field_manager_mod, only: fm_path_name_len, fm_string_len, fm_exists, fm_get_index + use field_manager_mod, only: fm_string_len, fm_exists, fm_get_index use field_manager_mod, only: fm_new_list, fm_get_current_list, fm_change_list use field_manager_mod, only: fm_field_name_len, fm_type_name_len, fm_dump_list use field_manager_mod, only: fm_loop_over_list @@ -63,7 +63,7 @@ module atmos_ocean_fluxes_mod use fm_util_mod, only: fm_util_get_real_array, fm_util_get_real, fm_util_get_integer use fm_util_mod, only: fm_util_get_logical, fm_util_get_logical_array use fms_io_utils_mod, only: get_data_type_string - use platform_mod, only: r4_kind, r8_kind + use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN implicit none private @@ -135,8 +135,8 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, par integer :: length integer :: num_parameters integer :: outunit - character(len=fm_path_name_len) :: coupler_list - character(len=fm_path_name_len) :: current_list + character(len=FMS_PATH_LEN) :: coupler_list + character(len=FMS_PATH_LEN) :: current_list character(len=fm_string_len) :: flux_type_test character(len=fm_string_len) :: implementation_test character(len=256) :: error_header diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index ab616ed981..24431197ec 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -41,7 +41,7 @@ module coupler_types_mod use mpp_domains_mod, only: domain2D, mpp_redistribute use mpp_mod, only: mpp_error, FATAL, mpp_chksum use fms_string_utils_mod, only: string - use platform_mod, only: r4_kind, r8_kind, i8_kind + use platform_mod, only: r4_kind, r8_kind, i8_kind, FMS_FILE_LEN, FMS_PATH_LEN implicit none private @@ -103,8 +103,8 @@ module coupler_types_mod character(len=128) :: implementation = ' ' !< implementation logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file #ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. @@ -146,8 +146,8 @@ module coupler_types_mod character(len=128) :: implementation = ' ' !< implementation logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file #ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. @@ -207,8 +207,8 @@ module coupler_types_mod real(r8_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file #ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. @@ -253,8 +253,8 @@ module coupler_types_mod real(r8_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=124) :: ice_restart_file = ' ' !< ice_restart_file - character(len=124) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file #ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. @@ -309,8 +309,8 @@ module coupler_types_mod real(r8_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file logical :: use_atm_pressure !< use_atm_pressure logical :: use_10m_wind_speed !< use_10m_wind_speed logical :: pass_through_ice !< pass_through_ice @@ -350,8 +350,8 @@ module coupler_types_mod real(r8_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + character(len=FMS_FILE_LEN) :: ice_restart_file = ' ' !< ice_restart_file + character(len=FMS_FILE_LEN) :: ocean_restart_file = ' ' !< ocean_restart_file logical :: use_atm_pressure !< use_atm_pressure logical :: use_10m_wind_speed !< use_10m_wind_speed logical :: pass_through_ice !< pass_through_ice @@ -3076,15 +3076,15 @@ subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domai logical, optional,intent(in) :: ocean_restart !< If true, use the ocean restart file name. character(len=*),optional,intent(in) :: directory !< Directory where to open the file - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm + character(len=FMS_FILE_LEN), dimension(max(1,var%num_bcs)) :: rest_file_names + character(len=FMS_FILE_LEN) :: file_nm logical :: ocn_rest integer :: f, n, m character(len=20), allocatable, dimension(:) :: dim_names !< Array of dimension names character(len=20) :: io_type !< flag indicating io type: "read" "overwrite" logical, dimension(max(1,var%num_bcs)) :: file_is_open !< flag indicating if file is open - character(len=20) :: dir !< Directory where to open the file + character(len=FMS_PATH_LEN) :: dir !< Directory where to open the file if(var%set .and. var%num_bcs .gt. 0) then if(associated(var%bc) .eqv. associated(var%bc_r4)) then @@ -3358,15 +3358,15 @@ subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domai logical, optional,intent(in) :: ocean_restart !< If true, use the ocean restart file name. character(len=*),optional,intent(in) :: directory !< Directory where to open the file - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm + character(len=FMS_FILE_LEN), dimension(max(1,var%num_bcs)) :: rest_file_names + character(len=FMS_FILE_LEN) :: file_nm logical :: ocn_rest integer :: f, n, m character(len=20), allocatable, dimension(:) :: dim_names !< Array of dimension names character(len=20) :: io_type !< flag indicating io type: "read" "overwrite" logical, dimension(max(1,var%num_bcs)) :: file_is_open !< Flag indicating if file is open - character(len=20) :: dir !< Directory where to open the file + character(len=FMS_PATH_LEN) :: dir !< Directory where to open the file integer :: nz !< Length of the z direction of each file if(var%set .and. var%num_bcs .gt. 0) then diff --git a/data_override/README.MD b/data_override/README.MD index f9e19464aa..b35879edf2 100644 --- a/data_override/README.MD +++ b/data_override/README.MD @@ -7,29 +7,29 @@ - [How to use it?](README.MD#2-how-to-use-it) - [Converting legacy data_table to data_table.yaml](README.MD#3-converting-legacy-data_table-to-data_tableyaml) - [Examples](README.MD#4-examples) +- [External Weight File Structure](README.MD#5-external-weight-file-structure) #### 1. YAML Data Table format: Each entry in the data_table has the following key values: -- **gridname:** Name of the grid to interpolate the data to. The acceptable values are "ICE", "OCN", "ATM", and "LND" -- **fieldname_code:** Name of the field as it is in the code to interpolate. -- **fieldname_file:** Name of the field as it is writen in the file. **Required** only if overriding from a file -- **file_name:** Name of the file where the variable is located, including the directory. **Required** only if overriding from a file -- **interpol_method:** Method used to interpolate the field. The acceptable values are "bilinear", "bicubic", and "none". "none" implies that the field in the file is already in the model grid. The LIMA format is no longer supported. **Required** only if overriding from a file +- **grid_name:** Name of the grid to interpolate the data to. The acceptable values are "ICE", "OCN", "ATM", and "LND" +- **fieldname_in_model:** Name of the field as it is in the code to interpolate. +- **override_file:** Optional subsection with key/value pairs defining how to override from a netcdf file. + - **file_name:** Name of the file where the variable is located, including the directory + - **fieldname_in_file:** Name of the field as it is writen in the file + - **interp_method:** Method used to interpolate the field. The acceptable values are "bilinear", "bicubic", and "none". "none" implies that the field in the file is already in the model grid. The LIMA format is no longer supported + - **multi_file:** Optional subsection with key/value pairs to use multiple(3) input netcdf files instead of 1. Note that **file_name** must be the second file in the set when using multiple input netcdf files + - **prev_file_name:** The name of the first file in the set + - **next_file_name:** The name of the third file in the set + - **external_weights:** Optional subsection with key/value pairs defining the external weights file to used for the interpolation. + - **file_name:** Name of the file where the external weights are located, including the directory + - **source:** Name of the source that generated the external weights. The only acceptable value is "fregrid" - **factor:** Factor that will be multiplied after the data is interpolated - -If it is desired to interpolate the data to a region of the model grid. The following **optional** arguments are available. -- **region_type:** The region type. The acceptable values are "inside_region" and "outside_region" -- **lon_start:** The starting latitude in the same units as the grid data in the file -- **lon_end:** The ending latitude in the same units as the grid data in the file -- **lat_start:** The starting longitude in the same units as the grid data in the file -- **lon_end:** The ending longitude in the same units as the grid data in the file - -If it is desired to use multiple(3) input netcdf files instead of 1. The following **optional** keys are available. -- **is_multi_file:** Set to `True` is using the multi-file feature -- **prev_file_name:** The name of the first file in the set -- **next_file_name:** The name of the third file in the set - -Note that **file_name** must be the second file in the set. **prev_file_name** and/or **next_file_name** are required if **is_multi_file** is set to `True` +- **subregion:** Optional subsection with key/value pairs that define a subregion of the model grid to interpolate the data to. + - **type:** The region type. The acceptable values are "inside_region" and "outside_region" + - **lon_start:** The starting latitude in the same units as the grid data in the file + - **lon_end:** The ending latitude in the same units as the grid data in the file + - **lat_start:** The starting longitude in the same units as the grid data in the file + - **lon_end:** The ending longitude in the same units as the grid data in the file #### 2. How to use it? In order to use the yaml data format, [libyaml](https://github.com/yaml/libyaml) needs to be installed and linked with FMS. Additionally, FMS must be compiled with -Duse_yaml macro. If using autotools, you can add `--with-yaml`, which will add the macro for you and check that libyaml is linked correctly. @@ -55,21 +55,22 @@ In the **legacy format**, the data_table will look like: In the **yaml format**, the data_table will look like ``` data_table: - - gridname : ICE - fieldname_code : sic_obs - fieldname_file : sic - file_name : INPUT/hadisst_ice.data.nc - interpol_method : bilinear - factor : 0.01 + - grid_name : ICE + fieldname_in_model : sic_obs + override_file: + - file_name : INPUT/hadisst_ice.data.nc + fieldname_in_file : sic + interp_method : bilinear + factor : 0.01 ``` Which corresponds to the following model code: ```F90 call data_override('ICE', 'sic_obs', icec, Spec_Time) ``` where: -- `ICE` corresponds to the gridname in the data_table -- `sic_obs` corresponds to the fieldname_code in the data_table -- `icec` is the variable to write the data to +- `ICE` is the component domain for which the variable is being interpolated and corresponds to the grid_name in the data_table +- `sic_obs` corresponds to the fieldname_in_model in the data_table +- `icec` is the storage array that holds the interpolated data - `Spec_Time` is the time to interpolate the data to. Additionally, it is required to call data_override_init (in this case with the ICE domain). The grid_spec.nc file must also contain the coordinate information for the domain being used. @@ -82,15 +83,15 @@ call data_override_init(Ice_domain_in=Ice_domain) In the **legacy format**, the data_table will look like: ``` -"ICE", "sit_obs", "", "INPUT/hadisst_ice.data.nc", "none", 2.0 +"ICE", "sit_obs", "", "INPUT/hadisst_ice.data.nc", "none", 2.0 ``` In the **yaml format**, the data_table will look like: -``` +``` yaml data_table: - - gridname : ICE - fieldname_code : sit_obs - factor : 0.01 + - grid_name : ICE + fieldname_in_model : sit_obs + factor : 0.01 ``` Which corresponds to the following model code: @@ -98,9 +99,9 @@ Which corresponds to the following model code: call data_override('ICE', 'sit_obs', icec, Spec_Time) ``` where: -- `ICE` corresponds to the gridname in the data_table -- `sit_obs` corresponds to the fieldname_code in the data_table -- `icec` is the variable to write the data to +- `ICE` is the component domain for which the variable is being interpolated and corresponds to the grid_name in the data_table +- `sit_obs` corresponds to the fieldname_in_model in the data_table +- `icec` is the storage array that holds the interpolated data - `Spec_Time` is the time to interpolate the data to. Additionally, it is required to call data_override_init (in this case with the ICE domain). The grid_spec.nc file is still required to initialize data_override with the ICE domain. @@ -117,14 +118,15 @@ In the **legacy format**, the data_table will look like: ``` In the **yaml format**, the data_table will look like: -``` +``` yaml data_table: - - gridname : OCN - fieldname_code : runoff - fieldname_file : runoff - file_name : INPUT/runoff.daitren.clim.nc - interpol_method : none - factor : 1.0 + - grid_name : OCN + fieldname_in_model : runoff + override_file: + - file_name : INPUT/runoff.daitren.clim.nc + fieldname_in_file : runoff + interp_method : none + factor : 1.0 ``` Which corresponds to the following model code: @@ -132,9 +134,9 @@ Which corresponds to the following model code: call data_override('OCN', 'runoff', runoff_data, Spec_Time) ``` where: -- `OCN` corresponds to the gridname in the data_table -- `runoff` corresponds to the fieldname_code in the data_table -- `runoff_data` is the variable to write the data to +- `OCN` is the component domain for which the variable is being interpolated and corresponds to the grid_name in the data_table +- `runoff` corresponds to the fieldname_in_model in the data_table +- `runoff_data` is the storage array that holds the interpolated data - `Spec_Time` is the time to interpolate the data to. Additionally, it is required to call data_override_init (in this case with the ocean domain). The grid_spec.nc file is still required to initialize data_override with the ocean domain and to determine if the data in the file is in the same grid as the ocean. @@ -142,3 +144,59 @@ Additionally, it is required to call data_override_init (in this case with the o ```F90 call data_override_init(Ocn_domain_in=Ocn_domain) ``` + +**4.4** The following example uses the multi-file capability +``` yaml +data_table: + - grid_name : ICE + fieldname_in_model : sic_obs + override_file: + - file_name : INPUT/hadisst_ice.data_yr1.nc + fieldname_in_file : sic + interp_method : bilinear + multi_file: + - next_file_name: INPUT/hadisst_ice.data_yr2.nc + prev_file_name: INPUT/hadisst_ice.data_yr0.nc + factor : 0.01 +``` +Data override determines which file to use depending on the model time. This is to prevent having to combine the 3 yearly files into one, since the end of the previous file and the beginning of the next file are needed for yearly simulations. + +**4.5** The following example uses the external weight file capability +``` yaml +data_table: + - grid_name : ICE + fieldname_in_model : sic_obs + override_file: + - file_name : INPUT/hadisst_ice.data.nc + fieldname_in_file : sic + interp_method : bilinear + external_weights: + - file_name: INPUT/remamp_file.nc + source: fregrid + factor : 0.01 +``` + +#### 5. External Weight File Structure + +**5.1** Bilinear weight file example from fregrid + +``` +dimensions: + nlon = 5 ; + nlat = 6 ; + three = 3 ; + four = 4 ; +variables: + int index(three, nlat, nlon) ; + double weight(four, nlat, nlon) ; +``` +- `nlon` and `nlat` must be equal to the size of the global domain. +- `index(1,:,:)` corresponds to the index (i) of the longitudes point in the data file, closest to each model lon, lat +- `index(2,:,:)` corresponds to the index (j) of the lattidude point in the data file, closest to each model lon, lat +- `index(3,:,:)` corresponds to the tile (it should be 1 since data_override does not support interpolation **from** cubesphere grids) + - From there the four corners are (i,j), (i,j+1) (i+1) (i+1,j+1) +- The weights for the four corners + - weight(:,:,1) -> (i,j) + - weight(:,:,2) -> (i,j+1) + - weight(:,:,3) -> (i+1,j) + - weight(:,:,4) -> (i+1,j+1) diff --git a/data_override/get_grid_version.F90 b/data_override/get_grid_version.F90 index 02107c7834..5b838651d1 100644 --- a/data_override/get_grid_version.F90 +++ b/data_override/get_grid_version.F90 @@ -24,7 +24,7 @@ !> @{ module get_grid_version_mod use constants_mod, only: DEG_TO_RAD -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN use mpp_mod, only : mpp_error,FATAL,NOTE, mpp_min, mpp_max use mpp_domains_mod, only : domain2d, operator(.NE.),operator(.EQ.) use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 84c22e9527..d5cc939029 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -21,13 +21,13 @@ ! modules. These modules are not intended to be used directly - they should be ! used through the data_override_mod API. See data_override.F90 for details. -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN use yaml_parser_mod use constants_mod, only: DEG_TO_RAD use mpp_mod, only : mpp_error, FATAL, WARNING, NOTE, stdout, stdlog, mpp_max use mpp_mod, only : input_nml_file use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_type, & - assignment(=) + horiz_interp_read_weights use time_interp_external2_mod, only: time_interp_external_init, & time_interp_external, & time_interp_external_bridge, get_time_axis, & @@ -61,14 +61,17 @@ type data_type character(len=3) :: gridname character(len=128) :: fieldname_code !< fieldname used in user's code (model) character(len=128) :: fieldname_file !< fieldname used in the netcdf data file - character(len=512) :: file_name !< name of netCDF data file + character(len=FMS_PATH_LEN) :: file_name !< name of netCDF data file character(len=128) :: interpol_method !< interpolation method (default "bilinear") + logical :: ext_weights + character(len=128) :: ext_weights_file_name + character(len=128) :: ext_weights_source real(FMS_DATA_OVERRIDE_KIND_) :: factor !< For unit conversion, default=1, see OVERVIEW above real(FMS_DATA_OVERRIDE_KIND_) :: lon_start, lon_end, lat_start, lat_end integer :: region_type logical :: multifile = .false. - character(len=512) :: prev_file_name !< name of netCDF data file for previous segment - character(len=512) :: next_file_name !< name of netCDF data file for next segment + character(len=FMS_PATH_LEN) :: prev_file_name !< name of netCDF data file for previous segment + character(len=FMS_PATH_LEN) :: next_file_name !< name of netCDF data file for next segment type(time_type), dimension(:), allocatable :: time_records type(time_type), dimension(:), allocatable :: time_prev_records type(time_type), dimension(:), allocatable :: time_next_records @@ -94,10 +97,21 @@ type override_type integer :: is_src, ie_src, js_src, je_src end type override_type +!> Private type for holding horiz_interp_type for a weight file +!! This is needed so that if variables use the same weight file, +!! then we won't have to read the weight file again +!> @ingroup data_override_mod +type fmsExternalWeights_type + character(len=:), allocatable :: weight_filename !< Name of the weight file + type(horiz_interp_type) :: horiz_interp !< Horiz interp type read in from the weight file +end type fmsExternalWeights_type + integer, parameter :: lkind = FMS_DATA_OVERRIDE_KIND_ integer, parameter :: max_table=100, max_array=100 integer :: table_size !< actual size of data table +integer :: nweight_files !< Number of weight files that have been used +type(fmsExternalWeights_type), allocatable, target :: external_weights(:) !< External weights types logical :: module_is_initialized = .FALSE. type(domain2D) :: ocn_domain,atm_domain,lnd_domain, ice_domain @@ -124,9 +138,15 @@ logical :: reproduce_null_char_bug = .false. !! to reproduce the mpp_io bug where lat/lon_bnd were !! not read correctly if null characters are present in !! the netcdf file +logical :: use_center_grid_points=.false. !< Flag indicating + !! whether or not to use the centroid values of the + !! supergrid from the grid file as opposed to calculating it + !! by taking the average of the four corner points. + !! This is only relevant to OCN and ICE grids. logical :: use_data_table_yaml = .false. -namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug, use_data_table_yaml +namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug, use_data_table_yaml, & + use_center_grid_points public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_, & @@ -152,7 +172,7 @@ subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_i type (domain2d), intent(in), optional :: Land_domain_in !> Land domain type(domainUG) , intent(in), optional :: Land_domainUG_in !> Land domain, unstructured grid - character(len=128) :: grid_file = 'INPUT/grid_spec.nc' + character(len=18), parameter :: grid_file = 'INPUT/grid_spec.nc' integer :: is,ie,js,je,use_get_grid_version integer :: i, iunit, io_status, ierr logical :: atm_on, ocn_on, lnd_on, ice_on, lndUG_on @@ -217,6 +237,8 @@ end if if (file_exists("data_table")) & call mpp_error(FATAL, "You cannot have the legacy data_table if use_data_table_yaml=.true.") call read_table_yaml(data_table) + allocate(external_weights(table_size)) + nweight_files = 0 else if (file_exists("data_table.yaml"))& call mpp_error(FATAL, "You cannot have the yaml data_table if use_data_table_yaml=.false.") @@ -324,7 +346,7 @@ end if 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 ) + min_glo_lon_ocn, max_glo_lon_ocn, use_center_grid_points) endif if (lnd_on .and. .not. allocated(lon_local_lnd) ) then @@ -338,7 +360,7 @@ end if 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 ) + min_glo_lon_ice, max_glo_lon_ice, use_center_grid_points ) endif end if if(use_get_grid_version .EQ. 2) then @@ -546,6 +568,7 @@ subroutine read_table(data_table) data_entry%lat_end = -1.0_lkind data_entry%region_type = NO_REGION endif + data_entry%ext_weights = .false. data_table(ntable) = data_entry enddo call mpp_error(FATAL,'too many enries in data_table') @@ -564,7 +587,8 @@ subroutine read_table_yaml(data_table) type(data_type), dimension(:), allocatable, intent(out) :: data_table !< Contents of the data_table.yaml integer, allocatable :: entry_id(:) - integer :: nentries + integer :: sub_block_id(1), sub2_block_id(1) + integer :: nentries, mentries integer :: i character(len=50) :: buffer integer :: file_id @@ -579,53 +603,90 @@ subroutine read_table_yaml(data_table) 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 check_for_valid_gridname(data_table(i)%gridname) - call get_value_from_key(file_id, entry_id(i), "fieldname_code", data_table(i)%fieldname_code) - - data_table(i)%fieldname_file = "" - call get_value_from_key(file_id, entry_id(i), "fieldname_file", data_table(i)%fieldname_file, & - & is_optional=.true.) - - data_table(i)%multifile = .false. - call get_value_from_key(file_id, entry_id(i), "is_multi_file", data_table(i)%multifile, & - & is_optional=.true.) - - if (data_table(i)%multifile) then - data_table(i)%prev_file_name = "" - data_table(i)%next_file_name = "" - call get_value_from_key(file_id, entry_id(i), "prev_file_name", data_table(i)%prev_file_name, & - & is_optional=.true.) - call get_value_from_key(file_id, entry_id(i), "next_file_name", data_table(i)%next_file_name, & - & is_optional=.true.) + 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), "grid_name", data_table(i)%gridname) + call check_for_valid_gridname(data_table(i)%gridname) + call get_value_from_key(file_id, entry_id(i), "fieldname_in_model", data_table(i)%fieldname_code) + + mentries = get_num_blocks(file_id, "override_file", parent_block_id=entry_id(i)) + data_table(i)%file_name = "" + data_table(i)%fieldname_file = "" + data_table(i)%interpol_method = "none" + data_table(i)%multifile = .false. + data_table(i)%ext_weights = .false. + data_table(i)%region_type = NO_REGION + data_table(i)%prev_file_name = "" + data_table(i)%next_file_name = "" + data_table(i)%ext_weights_file_name = "" + data_table(i)%ext_weights_source = "" + + ! If there is no override_file block, then not overriding from file, so move on to the next entry + if (mentries .eq. 0) cycle + + if(mentries.gt.1) call mpp_error(FATAL, "Too many override_file blocks in data table. "//& + "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& + trim(data_table(i)%fieldname_code)) + call get_block_ids(file_id, "override_file", sub_block_id, parent_block_id=entry_id(i)) + + call get_value_from_key(file_id, sub_block_id(1), "file_name", data_table(i)%file_name) + call get_value_from_key(file_id, sub_block_id(1), "fieldname_in_file", data_table(i)%fieldname_file) + call get_value_from_key(file_id, sub_block_id(1), "interp_method", data_table(i)%interpol_method) + call check_interpol_method(data_table(i)%interpol_method, data_table(i)%file_name, & + & data_table(i)%fieldname_file) + + mentries = get_num_blocks(file_id, "multi_file", parent_block_id=sub_block_id(1)) + if(mentries.gt.1) call mpp_error(FATAL, "Too many multi_file blocks in tata table. "//& + "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& + trim(data_table(i)%fieldname_code)) + + if(mentries.gt.0) data_table(i)%multifile = .true. + + if (data_table(i)%multifile) then + call get_block_ids(file_id, "multi_file", sub2_block_id, parent_block_id=sub_block_id(1)) + call get_value_from_key(file_id, sub2_block_id(1), "prev_file_name", data_table(i)%prev_file_name) + call get_value_from_key(file_id, sub2_block_id(1), "next_file_name", data_table(i)%next_file_name) if (trim(data_table(i)%prev_file_name) .eq. "" .and. trim(data_table(i)%next_file_name) .eq. "") & call mpp_error(FATAL, "The prev_file_name and next_file_name must be present if is_multi_file. "//& "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& trim(data_table(i)%fieldname_code)) - endif + endif + + mentries = get_num_blocks(file_id, "external_weights", parent_block_id=sub_block_id(1)) + if(mentries.gt.1) call mpp_error(FATAL, "Too many external_weight blocks in data table. "//& + "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& + trim(data_table(i)%fieldname_code)) + + if(mentries.gt.0) data_table(i)%ext_weights = .true. - data_table(i)%file_name = "" - call get_value_from_key(file_id, entry_id(i), "file_name", data_table(i)%file_name, & - & is_optional=.true.) + if (data_table(i)%ext_weights) then + call get_block_ids(file_id, "external_weights", sub2_block_id, parent_block_id=sub_block_id(1)) + call get_value_from_key(file_id, sub2_block_id(1), "file_name", data_table(i)%ext_weights_file_name) + call get_value_from_key(file_id, sub2_block_id(1), "source", data_table(i)%ext_weights_source) + if (trim(data_table(i)%ext_weights_file_name) .eq. "" .and. trim(data_table(i)%ext_weights_source) .eq. "") & + call mpp_error(FATAL, "The file_name and source must be present when using external weights"//& + "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& + trim(data_table(i)%fieldname_code)) + endif - data_table(i)%interpol_method = "none" - call get_value_from_key(file_id, entry_id(i), "interpol_method", data_table(i)%interpol_method, & - & is_optional=.true.) - call check_interpol_method(data_table(i)%interpol_method, data_table(i)%file_name, & - data_table(i)%fieldname_file) + mentries = get_num_blocks(file_id, "subregion", parent_block_id=entry_id(i)) + if(mentries.gt.1) call mpp_error(FATAL, "Too many subregion blocks in data table. "//& + "Check your data_table.yaml entry for field:"//trim(data_table(i)%gridname)//":"//& + trim(data_table(i)%fieldname_code)) - call get_value_from_key(file_id, entry_id(i), "factor", data_table(i)%factor) - buffer = "" - call get_value_from_key(file_id, entry_id(i), "region_type", buffer, is_optional=.true.) - call check_and_set_region_type(buffer, data_table(i)%region_type) + buffer = "" + if(mentries.gt.0) then + call get_block_ids(file_id, "subregion", sub_block_id, parent_block_id=entry_id(i)) + call get_value_from_key(file_id, sub_block_id(1), "type", buffer) + endif + call check_and_set_region_type(buffer, data_table(i)%region_type) if (data_table(i)%region_type .ne. NO_REGION) then - 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.) + call get_value_from_key(file_id, sub_block_id(1), "lon_start", data_table(i)%lon_start) + call get_value_from_key(file_id, sub_block_id(1), "lon_end", data_table(i)%lon_end) + call get_value_from_key(file_id, sub_block_id(1), "lat_start", data_table(i)%lat_start) + call get_value_from_key(file_id, sub_block_id(1), "lat_end", data_table(i)%lat_end) call check_valid_lat_lon(data_table(i)%lon_start, data_table(i)%lon_end, & - data_table(i)%lat_start, data_table(i)%lat_end) + data_table(i)%lat_start, data_table(i)%lat_end) endif end do @@ -786,9 +847,9 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data_out,time,override,data type(time_type) :: first_record !< first record of "current" file type(time_type) :: last_record !< last record of "current" file - character(len=512) :: filename !< file containing source data - character(len=512) :: prevfilename !< file containing previous source data, when using multiple files - character(len=512) :: nextfilename !< file containing next source data, when using multiple files + character(len=FMS_PATH_LEN) :: filename !< file containing source data + character(len=FMS_PATH_LEN) :: prevfilename !< file containing previous source data, when using multiple files + character(len=FMS_PATH_LEN) :: nextfilename !< file containing next source data, when using multiple files character(len=128) :: fieldname !< fieldname used in the data file integer :: index1 !< field index in data_table integer :: dims(4) @@ -980,12 +1041,12 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,return_data,time,override,d integer, optional, intent(in) :: is_in, ie_in, js_in, je_in logical, dimension(:,:,:), allocatable :: mask_out - character(len=512) :: filename !< file containing source data - character(len=512) :: filename2 !< file containing source data - character(len=512) :: prevfilename !< file containing source data for previous file - character(len=512) :: prevfilename2 !< file containing source data for previous file - character(len=512) :: nextfilename !< file containing source data for next file - character(len=512) :: nextfilename2 !< file containing source data for next file + character(len=FMS_PATH_LEN) :: filename !< file containing source data + character(len=FMS_PATH_LEN) :: filename2 !< file containing source data + character(len=FMS_PATH_LEN) :: prevfilename !< file containing source data for previous file + character(len=FMS_PATH_LEN) :: prevfilename2 !< file containing source data for previous file + character(len=FMS_PATH_LEN) :: nextfilename !< file containing source data for next file + character(len=FMS_PATH_LEN) :: nextfilename2 !< file containing source data for next file character(len=128) :: fieldname !< fieldname used in the data file integer :: i,j integer :: dims(4) @@ -1026,6 +1087,9 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,return_data,time,override,d integer :: endingj !< Ending y index for the compute domain relative to the input buffer integer :: nhalox !< Number of halos in the x direction integer :: nhaloy !< Number of halos in the y direction + logical :: found_weight_file !< .True. if the weight file has already been read + integer :: nglat !< Number of latitudes in the global domain + integer :: nglon !< Number of longitudes in the global domain use_comp_domain = .false. if(.not.module_is_initialized) & @@ -1418,18 +1482,45 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,return_data,time,override,d call mpp_error(FATAL,'error: gridname not recognized in data_override') end select - select case (data_table(index1)%interpol_method) - case ('bilinear') + if (data_table(index1)%ext_weights) then + found_weight_file = .false. + do i = 1, nweight_files + if (external_weights(i)%weight_filename .eq. trim(data_table(index1)%ext_weights_file_name)) then + override_array(curr_position)%horz_interp(window_id) = external_weights(i)%horiz_interp + found_weight_file = .true. + exit + endif + enddo + + if (.not. found_weight_file) then + nweight_files = nweight_files + 1 + external_weights(nweight_files)%weight_filename = trim(data_table(index1)%ext_weights_file_name) + + call mpp_get_global_domain(domain, xsize=nglon, ysize=nglat) + call horiz_interp_read_weights(external_weights(nweight_files)%horiz_interp, & + external_weights(nweight_files)%weight_filename, & + lon_local(isw:iew,jsw:jew), lat_local(isw:iew,jsw:jew), & + override_array(curr_position)%lon_in(is_src:ie_src+1), & + override_array(curr_position)%lat_in(js_src:je_src+1), & + data_table(index1)%ext_weights_source, & + data_table(index1)%interpol_method, isw, iew, jsw, jew, nglon, nglat) + + override_array(curr_position)%horz_interp(window_id) = external_weights(nweight_files)%horiz_interp + endif + else + select case (data_table(index1)%interpol_method) + case ('bilinear') call horiz_interp_new (override_array(curr_position)%horz_interp(window_id), & override_array(curr_position)%lon_in(is_src:ie_src+1), & override_array(curr_position)%lat_in(js_src:je_src+1), & lon_local(isw:iew,jsw:jew), lat_local(isw:iew,jsw:jew), interp_method="bilinear") - case ('bicubic') + case ('bicubic') call horiz_interp_new (override_array(curr_position)%horz_interp(window_id), & override_array(curr_position)%lon_in(is_src:ie_src+1), & override_array(curr_position)%lat_in(js_src:je_src+1), & lon_local(isw:iew,jsw:jew), lat_local(isw:iew,jsw:jew), interp_method="bicubic") - end select + end select + endif override_array(curr_position)%need_compute(window_id) = .false. endif diff --git a/data_override/include/get_grid_version.inc b/data_override/include/get_grid_version.inc index fd65588e46..7d1e05efed 100644 --- a/data_override/include/get_grid_version.inc +++ b/data_override/include/get_grid_version.inc @@ -143,7 +143,8 @@ end subroutine GET_GRID_VERSION_1_ !> Get global lon and lat of three model (target) grids from mosaic.nc. !! Currently we assume the refinement ratio is 2 and there is one tile on each pe. -subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) +subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon, & + use_center_grid_points) integer, parameter :: lkind = FMS_GET_GRID_VERSION_KIND_ type(FmsNetcdfFile_t), intent(in) :: fileobj !< file object for grid file @@ -152,6 +153,11 @@ subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lo integer, intent(in) :: isc, iec, jsc, jec real(lkind), dimension(isc:,jsc:), intent(out) :: lon, lat real(lkind), intent(out) :: min_lon, max_lon + logical, optional, intent(in) :: use_center_grid_points !< Flag indicating whether or not to use the + !! centroid values of the supergrid from the + !! grid file as opposed to calcuating it by + !! taking the average of the four corner points. + !! This is only relevant to OCN and ICE grids. integer :: i, j, siz(2) integer :: nlon, nlat ! size of global grid @@ -159,11 +165,15 @@ subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lo integer :: isd, ied, jsd, jed integer :: isg, ieg, jsg, jeg integer :: isc2, iec2, jsc2, jec2 - character(len=256) :: solo_mosaic_file, grid_file + character(len=FMS_PATH_LEN) :: solo_mosaic_file, grid_file real(lkind), allocatable :: tmpx(:,:), tmpy(:,:) logical :: open_solo_mosaic type(FmsNetcdfFile_t) :: mosaicfileobj, tilefileobj integer :: start(2), nread(2) + logical :: use_center_grid_points_local + + use_center_grid_points_local = .false. + if (present(use_center_grid_points)) use_center_grid_points_local = use_center_grid_points if(trim(mod_name) .NE. 'atm' .AND. trim(mod_name) .NE. 'ocn' .AND. & trim(mod_name) .NE. 'ice' .AND. trim(mod_name) .NE. 'lnd' ) call mpp_error(FATAL, & @@ -215,20 +225,20 @@ subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lo call read_data( tilefileobj, 'y', tmpy, corner=start,edge_lengths=nread) ! copy data onto model grid - if(trim(mod_name) == 'ocn' .OR. trim(mod_name) == 'ice') then - do j = jsc, jec - do i = isc, iec - lon(i,j) = (tmpx(i*2-1,j*2-1)+tmpx(i*2+1,j*2-1)+tmpx(i*2+1,j*2+1)+tmpx(i*2-1,j*2+1))*0.25_lkind - lat(i,j) = (tmpy(i*2-1,j*2-1)+tmpy(i*2+1,j*2-1)+tmpy(i*2+1,j*2+1)+tmpy(i*2-1,j*2+1))*0.25_lkind - end do - end do + if(trim(mod_name) == 'atm' .OR. trim(mod_name) == 'lnd' .OR. use_center_grid_points_local) then + do j = jsc, jec + do i = isc, iec + lon(i,j) = tmpx(i*2,j*2) + lat(i,j) = tmpy(i*2,j*2) + end do + end do else - do j = jsc, jec - do i = isc, iec - lon(i,j) = tmpx(i*2,j*2) - lat(i,j) = tmpy(i*2,j*2) - end do - end do + do j = jsc, jec + do i = isc, iec + lon(i,j) = (tmpx(i*2-1,j*2-1)+tmpx(i*2+1,j*2-1)+tmpx(i*2+1,j*2+1)+tmpx(i*2-1,j*2+1))*0.25_lkind + lat(i,j) = (tmpy(i*2-1,j*2-1)+tmpy(i*2+1,j*2-1)+tmpy(i*2+1,j*2+1)+tmpy(i*2-1,j*2+1))*0.25_lkind + end do + end do endif ! convert to radian diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90 index ed898a52d3..f4c2e75ab1 100644 --- a/diag_integral/diag_integral.F90 +++ b/diag_integral/diag_integral.F90 @@ -28,7 +28,7 @@ module diag_integral_mod !############################################################################### -use platform_mod, only: i8_kind +use platform_mod, only: i8_kind, FMS_FILE_LEN use time_manager_mod, only: time_type, get_time, set_time, & time_manager_init, & operator(+), operator(-), & @@ -135,16 +135,13 @@ module diag_integral_mod !------------------------------------------------------------------------------- !------ namelist ------- -integer, parameter :: & - mxch = 64 !< maximum number of characters in - !! the optional output file name real(r8_kind) :: & output_interval = -1.0_r8_kind !< time interval at which integrals !! are to be output character(len=8) :: & time_units = 'hours' !< time units associated with !! output_interval -character(len=mxch) :: & +character(len=FMS_FILE_LEN) :: & file_name = ' ' !< optional integrals output file name logical :: & print_header = .true. !< print a header for the integrals @@ -1081,14 +1078,14 @@ end function vert_diag_integral !> @brief Adds .ens_## to the diag_integral.out file name !! @return character array updated_file_name function ensemble_file_name(fname) result(updated_file_name) - character (len=mxch), intent(inout) :: fname - character (len=mxch) :: updated_file_name + character (len=*), intent(inout) :: fname + character (len=FMS_FILE_LEN) :: updated_file_name integer :: ensemble_id_int character(len=7) :: ensemble_suffix character(len=2) :: ensemble_id_char integer :: i !> Make sure the file name short enough to handle adding the ensemble number - if (len(trim(fname)) > mxch-7) call error_mesg ('diag_integral_mod :: ensemble_file_name', & + if (len(trim(fname)) > FMS_FILE_LEN-7) call error_mesg ('diag_integral_mod :: ensemble_file_name', & trim(fname)//" is too long and can not support adding ens_XX. Please shorten the "//& "file_name in the diag_integral_nml", FATAL) !> Get the ensemble ID and convert it to a string @@ -1107,7 +1104,7 @@ function ensemble_file_name(fname) result(updated_file_name) !> Loop through to find the last period do i=len(trim(fname)),2,-1 if (fname(i:i) == ".") then - updated_file_name = fname(1:i-1)//trim(ensemble_suffix)//fname(i:mxch) + updated_file_name = fname(1:i-1)//trim(ensemble_suffix)//fname(i:len(fname)) return endif enddo diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index abf08d18f7..3019e2b8ae 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -180,7 +180,7 @@ MODULE diag_data_mod !> @brief Type to define the diagnostic files that will be written as defined by the diagnostic table. !> @ingroup diag_data_mod TYPE file_type - CHARACTER(len=128) :: name !< Name of the output file. + CHARACTER(len=FMS_FILE_LEN) :: name !< Name of the output file. CHARACTER(len=128) :: long_name INTEGER, DIMENSION(max_fields_per_file) :: fields INTEGER :: num_fields @@ -611,8 +611,8 @@ function get_var_type(var) & type is (character(len=*)) var_type = string class default - call mpp_error(FATAL, "get_var_type:: The variable does not have a supported type. "& - &"The supported types are r4, r8, i4, i8 and string.") + call mpp_error(FATAL, "get_var_type:: The variable does not have a supported type. & + &The supported types are r4, r8, i4, i8 and string.") end select end function get_var_type diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index be448fcfb6..0714cfe59f 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1415,7 +1415,7 @@ SUBROUTINE add_associated_files(file_num, cm_file_num, cm_ind) INTEGER :: year, month, day, hour, minute, second INTEGER :: n CHARACTER(len=25) :: date_prefix - CHARACTER(len=256) :: asso_file_name + CHARACTER(len=FMS_FILE_LEN) :: asso_file_name ! Create the date_string IF ( prepend_date ) THEN diff --git a/diag_manager/diag_output.F90 b/diag_manager/diag_output.F90 index 095f8e659c..20b263566e 100644 --- a/diag_manager/diag_output.F90 +++ b/diag_manager/diag_output.F90 @@ -109,7 +109,7 @@ SUBROUTINE diag_output_init (file_name, file_title, file_unit,& integer, allocatable, dimension(:) :: current_pelist integer :: mype !< The pe you are on character(len=9) :: mype_string !< a string to store the pe - character(len=128) :: filename_tile !< Filename with the tile number included + character(len=FMS_FILE_LEN) :: filename_tile !< Filename with the tile number included !! It is needed for subregional diagnostics !---- initialize mpp_io ---- diff --git a/diag_manager/diag_table.F90 b/diag_manager/diag_table.F90 index 5578bdaa38..f0e749d465 100644 --- a/diag_manager/diag_table.F90 +++ b/diag_manager/diag_table.F90 @@ -255,6 +255,7 @@ MODULE diag_table_mod USE diag_data_mod, ONLY: global_descriptor, get_base_time, set_base_time, & & DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name USE diag_util_mod, ONLY: init_file, check_duplicate_output_fields, init_input_field, init_output_field + USE platform_mod, ONLY: FMS_FILE_LEN IMPLICIT NONE @@ -283,7 +284,7 @@ MODULE diag_table_mod INTEGER :: iOutput_freq_units INTEGER :: iNew_file_freq_units INTEGER :: iFile_duration_units - CHARACTER(len=128) :: file_name + CHARACTER(len=FMS_FILE_LEN) :: file_name CHARACTER(len=10) :: output_freq_units CHARACTER(len=10) :: time_units CHARACTER(len=128) :: long_name diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 216f14bad3..379e6aaae3 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -1654,10 +1654,11 @@ SUBROUTINE opening_file(file, time, filename_time) INTEGER, ALLOCATABLE :: axesc(:) ! indices if compressed axes associated with the field LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields CHARACTER(len=7) :: avg_name = 'average' - CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name, req_fields, fieldname + CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, aux_name, req_fields, fieldname + CHARACTER(len=FMS_FILE_LEN) :: filename CHARACTER(len=128) :: suffix, base_name CHARACTER(len=32) :: time_name, timeb_name,time_longname, timeb_longname, cart_name - CHARACTER(len=256) :: fname + CHARACTER(len=FMS_FILE_LEN) :: fname CHARACTER(len=24) :: start_date TYPE(domain1d) :: domain TYPE(domain2d) :: domain2 diff --git a/diag_manager/diag_yaml_format.md b/diag_manager/diag_yaml_format.md index d8221956d5..d9e93c3593 100644 --- a/diag_manager/diag_yaml_format.md +++ b/diag_manager/diag_yaml_format.md @@ -100,6 +100,9 @@ Below are some *optional* keys that may be added. - **new_file_freq** is a string that defines the frequency and the frequency units (with a space between the frequency number and units) for closing the existing file - **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq” - **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle +- **reduction** is the reduction method that will be used for all the variables in the file. This is overriden if the reduction is specified at the variable level. The acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum. +- **kind** is a string that defines the type of variable as it will be written out in the file. This is overriden if the kind is specified at the variable level. Acceptable values are r4, r8, i4, and i8. +- **module** is a string that defines the module where the variable is registered in the model code. This is overriden if the module is specified at the variable level. **Example:** The following will create a new file every 6 hours starting at Jan 1 2020. Variable data will be written to the file every 6 hours. diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index a28d22b291..0befd2988a 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -1033,8 +1033,8 @@ subroutine check_if_valid_domain_position(domain_position) select case (domain_position) case (CENTER, NORTH, EAST) case default - call mpp_error(FATAL, "diag_axit_init: Invalid domain_positon. "& - "The acceptable values are NORTH, EAST, CENTER") + call mpp_error(FATAL, "diag_axit_init: Invalid domain_positon. & + &The acceptable values are NORTH, EAST, CENTER") end select end subroutine check_if_valid_domain_position @@ -1045,8 +1045,8 @@ subroutine check_if_valid_direction(direction) select case(direction) case(-1, 0, 1) case default - call mpp_error(FATAL, "diag_axit_init: Invalid direction. "& - "The acceptable values are-1 0 1") + call mpp_error(FATAL, "diag_axit_init: Invalid direction. & + &The acceptable values are-1 0 1") end select end subroutine check_if_valid_direction diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 550037a904..6b4b61f704 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -383,18 +383,18 @@ subroutine fms_register_diag_field_obj & if (present(area)) then if (area < 0) call mpp_error("fms_register_diag_field_obj", & - "The area id passed with field_name"//trim(varname)//" has not been registered."& - "Check that there is a register_diag_field call for the AREA measure and that is in the"& - "diag_table.yaml", FATAL) + "The area id passed with field_name"//trim(varname)//" has not been registered. & + &Check that there is a register_diag_field call for the AREA measure and that is in the & + &diag_table.yaml", FATAL) allocate(this%area) this%area = area endif if (present(volume)) then if (volume < 0) call mpp_error("fms_register_diag_field_obj", & - "The volume id passed with field_name"//trim(varname)//" has not been registered."& - "Check that there is a register_diag_field call for the VOLUME measure and that is in the"& - "diag_table.yaml", FATAL) + "The volume id passed with field_name"//trim(varname)//" has not been registered. & + &Check that there is a register_diag_field call for the VOLUME measure and that is in the & + &diag_table.yaml", FATAL) allocate(this%volume) this%volume = volume endif @@ -1610,9 +1610,9 @@ subroutine add_area_volume(this, area, volume) if (area > 0) then this%area = area else - call mpp_error(FATAL, "diag_field_add_cell_measures: the area id is not valid. "& - &"Verify that the area_id passed in to the field:"//this%varname//& - &" is valid and that the field is registered and in the diag_table.yaml") + call mpp_error(FATAL, "diag_field_add_cell_measures: the area id is not valid. & + &Verify that the area_id passed in to the field:"//this%varname// & + " is valid and that the field is registered and in the diag_table.yaml") endif endif @@ -1620,9 +1620,9 @@ subroutine add_area_volume(this, area, volume) if (volume > 0) then this%volume = volume else - call mpp_error(FATAL, "diag_field_add_cell_measures: the volume id is not valid. "& - &"Verify that the volume_id passed in to the field:"//this%varname//& - &" is valid and that the field is registered and in the diag_table.yaml") + call mpp_error(FATAL, "diag_field_add_cell_measures: the volume id is not valid. & + &Verify that the volume_id passed in to the field:"//this%varname// & + " is valid and that the field is registered and in the diag_table.yaml") endif endif @@ -1899,7 +1899,7 @@ subroutine generate_associated_files_att(this, att, start_time) type(time_type), intent(in) :: start_time !< The start_time for the field's file character(len=:), allocatable :: field_name !< Name of the area/volume field - character(len=MAX_STR_LEN) :: file_name !< Name of the file the area/volume field is in! + character(len=FMS_FILE_LEN) :: file_name !< Name of the file the area/volume field is in! character(len=128) :: start_date !< Start date to append to the begining of the filename integer :: year, month, day, hour, minute, second diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 612e080db1..5f9a2536a5 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -50,6 +50,7 @@ module fms_diag_file_object_mod use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, & uppercase, lowercase, NOTE +use platform_mod, only: FMS_FILE_LEN implicit none private @@ -1018,8 +1019,8 @@ subroutine add_start_time(this, start_time) !! this%start_time was already updated so make sure it is the same for the current variable !! or error out if (this%start_time .ne. start_time)& - call mpp_error(FATAL, "The variables associated with the file:"//this%get_file_fname()//" have"& - &" different start_time") + call mpp_error(FATAL, "The variables associated with the file:"//this%get_file_fname()//" have & + &different start_time") else !> If the this%start_time is equal to the diag_init_time, !! simply update it with the start_time and set up the *_output variables @@ -1115,10 +1116,10 @@ subroutine open_diag_file(this, time_step, file_is_opened) class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open class(diagDomain_t), pointer :: domain !< The domain used in the file character(len=:), allocatable :: diag_file_name !< The file name as defined in the yaml - character(len=128) :: base_name !< The file name as defined in the yaml + character(len=FMS_FILE_LEN) :: base_name !< The file name as defined in the yaml !! without the wildcard definition - character(len=128) :: file_name !< The file name as it will be written to disk - character(len=128) :: temp_name !< Temp variable to store the file_name + character(len=FMS_FILE_LEN) :: file_name !< The file name as it will be written to disk + character(len=FMS_FILE_LEN) :: temp_name !< Temp variable to store the file_name character(len=128) :: start_date !< The start_time as a string that will be added to !! the begining of the filename (start_date.filename) character(len=128) :: suffix !< The current time as a string that will be added to @@ -1694,7 +1695,7 @@ subroutine write_field_metadata(this, diag_field, diag_axis) logical :: is_regional !< Flag indicating if the field is in a regional file character(len=255) :: cell_measures !< cell_measures attributes for the field logical :: need_associated_files !< .True. if the 'associated_files' global attribute is needed - character(len=255) :: associated_files !< Associated files attribute to add + character(len=FMS_FILE_LEN) :: associated_files !< Associated files attribute to add is_regional = this%is_regional() diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90 index 92952ecadc..0a4f0737e0 100644 --- a/diag_manager/fms_diag_input_buffer.F90 +++ b/diag_manager/fms_diag_input_buffer.F90 @@ -133,8 +133,8 @@ function allocate_input_buffer_object(this, input_data, axis_ids, diag_axis) & allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) this%buffer = 0_i8_kind class default - err_msg = "The data input is not one of the supported types."& - "Only r4, r8, i4, and i8 types are supported." + err_msg = "The data input is not one of the supported types. & + &Only r4, r8, i4, and i8 types are supported." end select this%weight = 1.0_r8_kind diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a1fc92cc31..c985a6c30d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -511,8 +511,8 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, axis_l type is (fmsDiagFullAxis_type) if(present(edges)) then if (edges < 0 .or. edges > this%registered_axis) & - call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "& - "Call diag_axis_init for the edge axis first") + call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. & + &Call diag_axis_init for the edge axis first") select type (edges_axis => this%diag_axis(edges)%axis) type is (fmsDiagFullAxis_type) edges_name = edges_axis%get_axis_name() diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 17ce86e4d5..a1c9b0b805 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -43,7 +43,7 @@ module fms_diag_yaml_mod use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique, string, & fms_f2c_string -use platform_mod, only: r4_kind, i4_kind, r8_kind, i8_kind +use platform_mod, only: r4_kind, i4_kind, r8_kind, i8_kind, FMS_FILE_LEN use fms_mod, only: lowercase implicit none @@ -77,7 +77,7 @@ module fms_diag_yaml_mod !> @brief type to hold an array of sorted diag_files type fileList_type - character(len=255), allocatable :: file_name(:) !< Array of diag_field + character(len=FMS_FILE_LEN), allocatable :: file_name(:) !< Array of diag_field type(c_ptr), allocatable :: file_pointer(:) !< Array of pointers integer, allocatable :: diag_file_indices(:) !< Index of the file in the diag_file array end type @@ -139,6 +139,15 @@ module fms_diag_yaml_mod !! and values(dim=2) to be !! added as global meta data to !! the file + character (len=:), allocatable :: default_var_precision !< The precision for all of the variables in the file + !! This may be overriden if the precison was defined + !! at the variable level + character (len=:), allocatable :: default_var_reduction !< The reduction for all of the variables in the file + !! This may be overriden if the reduction was defined at + !! the variable level + character (len=:), allocatable :: default_var_module !< The module for all of the variables in the file + !! This may be overriden if the modules was defined at the + !! variable level contains !> All getter functions (functions named get_x(), for member field named x) @@ -468,7 +477,8 @@ subroutine diag_yaml_object_init(diag_subset_output) diag_yaml%diag_fields(var_count)%var_axes_names = "" diag_yaml%diag_fields(var_count)%var_file_is_subregional = diag_yaml%diag_files(file_count)%has_file_sub_region() - call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count), allow_averages) + call fill_in_diag_fields(diag_yaml_id, diag_yaml%diag_files(file_count), var_ids(j), & + diag_yaml%diag_fields(var_count), allow_averages) !> Save the variable name in the diag_file type diag_yaml%diag_files(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname @@ -604,12 +614,19 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, yaml_fileobj) &" has multiple global_meta blocks") endif + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "reduction", yaml_fileobj%default_var_reduction, & + is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "kind", yaml_fileobj%default_var_precision, & + is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "module", yaml_fileobj%default_var_module, & + is_optional=.true.) end subroutine !> @brief Fills in a diagYamlFilesVar_type with the contents of a variable block in !! diag_table.yaml -subroutine fill_in_diag_fields(diag_file_id, var_id, field, allow_averages) +subroutine fill_in_diag_fields(diag_file_id, yaml_fileobj, var_id, field, allow_averages) integer, intent(in) :: diag_file_id !< Id of the file block in the yaml file + type(diagYamlFiles_type), intent(in) :: yaml_fileobj !< The yaml file obj for the variables integer, intent(in) :: var_id !< Id of the variable block in the yaml file type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into logical, intent(in) :: allow_averages !< .True. if averages are allowed for this file @@ -623,8 +640,17 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field, allow_averages) character(len=:), ALLOCATABLE :: buffer !< buffer to store the reduction method as it is read from the yaml call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname) - call diag_get_value_from_key(diag_file_id, var_id, "reduction", buffer) + + if (yaml_fileobj%default_var_reduction .eq. "") then + !! If there is no default, the reduction method is required + call diag_get_value_from_key(diag_file_id, var_id, "reduction", buffer) + else + call diag_get_value_from_key(diag_file_id, var_id, "reduction", buffer, is_optional=.true.) + !! If the reduction was not set for the variable, override it with the default + if (trim(buffer) .eq. "") buffer = yaml_fileobj%default_var_reduction + endif call set_field_reduction(field, buffer) + deallocate(buffer) if (.not. allow_averages) then if (field%var_reduction .ne. time_none) & @@ -633,9 +659,27 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field, allow_averages) "Check your diag_table.yaml for the field:"//trim(field%var_varname)) endif - call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) - deallocate(buffer) - call diag_get_value_from_key(diag_file_id, var_id, "kind", buffer) + if (yaml_fileobj%default_var_module .eq. "") then + call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) + else + call diag_get_value_from_key(diag_file_id, var_id, "module", buffer, is_optional=.true.) + !! If the module was set for the variable, override it with the default + if (trim(buffer) .eq. "") then + field%var_module = yaml_fileobj%default_var_module + else + field%var_module = trim(buffer) + endif + deallocate(buffer) + endif + + if (yaml_fileobj%default_var_precision .eq. "") then + !! If there is no default, the kind is required + call diag_get_value_from_key(diag_file_id, var_id, "kind", buffer) + else + call diag_get_value_from_key(diag_file_id, var_id, "kind", buffer, is_optional=.true.) + !! If the kind was set for the variable, override it with the default + if (trim(buffer) .eq. "") buffer = yaml_fileobj%default_var_precision + endif call set_field_kind(field, buffer) call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname, is_optional=.true.) @@ -936,8 +980,8 @@ function set_valid_time_units(time_units, error_msg) & time_units_int = DIAG_YEARS case default time_units_int =DIAG_NULL - call mpp_error(FATAL, trim(error_msg)//" is not valid. Acceptable values are "& - "seconds, minutes, hours, days, months, years") + call mpp_error(FATAL, trim(error_msg)//" is not valid. Acceptable values are & + &seconds, minutes, hours, days, months, years") end select end function set_valid_time_units @@ -1481,7 +1525,7 @@ function get_diag_files_id(indices) & integer :: field_id !< Indices of the field in the diag_yaml field array integer :: i !< For do loops - character(len=120) :: filename !< Filename of the field + character(len=FMS_FILE_LEN) :: filename !< Filename of the field integer, allocatable :: file_indices(:) !< Indices of the file in the sorted variable_list allocate(file_id(size(indices))) diff --git a/drifters/drifters.F90 b/drifters/drifters.F90 index 2afd7068ac..4f5110cbdd 100644 --- a/drifters/drifters.F90 +++ b/drifters/drifters.F90 @@ -95,6 +95,7 @@ module drifters_mod drifters_comm_gather, drifters_comm_update use cloud_interpolator_mod, only: cld_ntrp_linear_cell_interp, cld_ntrp_locate_cell, cld_ntrp_get_cell_values + use platform_mod, only: FMS_PATH_LEN implicit none private @@ -143,8 +144,8 @@ module drifters_mod real, allocatable :: rk4_k4(:,:) !< Runge Kutta coefficients holding !! intermediate results (positions) ! store filenames for convenience - character(len=MAX_STR_LEN) :: input_file !< store filenames for convenience - character(len=MAX_STR_LEN) :: output_file !< store filenames for convenience + character(len=FMS_PATH_LEN) :: input_file !< store filenames for convenience + character(len=FMS_PATH_LEN) :: output_file !< store filenames for convenience ! Runge Kutta stuff integer :: rk4_step !< Runge Kutta stuff logical :: rk4_completed !< Runge Kutta stuff diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index 88cfdbbbab..1ec0159891 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -129,7 +129,7 @@ module xgrid_mod use fms2_io_mod, only: FmsNetcdfFile_t, open_file, variable_exists, close_file use fms2_io_mod, only: FmsNetcdfDomainFile_t, read_data, get_dimension_size use fms2_io_mod, only: get_variable_units, dimension_exists -use platform_mod, only: r8_kind, i8_kind +use platform_mod, only: r8_kind, i8_kind, FMS_FILE_LEN implicit none private @@ -1530,11 +1530,12 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ real(r8_kind), dimension(:,:), allocatable :: check_data real(r8_kind), dimension(:,:,:), allocatable :: check_data_3D real(r8_kind), allocatable :: tmp_2d(:,:), tmp_3d(:,:,:) - character(len=256) :: xgrid_file, xgrid_name, xgrid_dimname - character(len=256) :: tile_file, mosaic_file - character(len=256) :: mosaic1, mosaic2, contact + character(len=FMS_FILE_LEN) :: xgrid_file, xgrid_name + character(len=FMS_FILE_LEN) :: tile_file, mosaic_file + character(len=256) :: mosaic1, mosaic2, contact, xgrid_dimname character(len=256) :: tile1_name, tile2_name - character(len=256), allocatable :: tile1_list(:), tile2_list(:), xgrid_filelist(:) + character(len=256), allocatable :: tile1_list(:), tile2_list(:) + character(len=FMS_FILE_LEN), allocatable :: xgrid_filelist(:) integer :: npes, npes2 integer, allocatable :: pelist(:) type(domain2d), save :: domain2 diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90 index 8b56e54fdb..5c4b44294b 100644 --- a/field_manager/field_manager.F90 +++ b/field_manager/field_manager.F90 @@ -191,7 +191,7 @@ module field_manager_mod write_version_number, & check_nml_error use fms2_io_mod, only: file_exists -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN, FMS_FILE_LEN #ifdef use_yaml use fm_yaml_mod #endif @@ -258,8 +258,10 @@ module field_manager_mod !> The length of a character string representing the field name. integer, parameter, public :: fm_field_name_len = 48 +!! TODO this should be removed in favor of the global FMS_PATH_LEN +!! when possible, currently used in ocean_BGC and land_lad2 !> The length of a character string representing the field path. -integer, parameter, public :: fm_path_name_len = 512 +integer, parameter, public :: fm_path_name_len = FMS_PATH_LEN !> The length of a character string representing character values for the field. integer, parameter, public :: fm_string_len = 1024 !> The length of a character string representing the various types that the values of the field can take. @@ -509,7 +511,7 @@ module field_manager_mod type(field_mgr_type), dimension(:), allocatable, private :: fields !< fields of field_mgr_type -character(len=fm_path_name_len) :: loop_list +character(len=FMS_PATH_LEN) :: loop_list character(len=fm_type_name_len) :: field_type_name(num_types) character(len=fm_field_name_len) :: save_root_name ! The string set is the set of characters. @@ -588,14 +590,14 @@ end subroutine field_manager_init !> @brief Routine to read and parse the field table yaml subroutine read_field_table_yaml(nfields, table_name) integer, intent(out), optional :: nfields !< number of fields -character(len=fm_string_len), intent(in), optional :: table_name !< Name of the field table, default +character(len=*), intent(in), optional :: table_name !< Name of the field table file, default is 'field_table.yaml' -character(len=fm_string_len) :: tbl_name !< field_table yaml file +character(len=FMS_FILE_LEN) :: tbl_name !< field_table yaml file character(len=fm_string_len) :: method_control !< field_table yaml file integer :: h, i, j, k, l, m !< dummy integer buffer -type (fmTable_t) :: my_table !< the field table +type (fmTable_t) :: my_table !< the field table integer :: model !< model assocaited with the current field -character(len=fm_path_name_len) :: list_name !< field_manager list name +character(len=FMS_PATH_LEN) :: list_name !< field_manager list name character(len=fm_string_len) :: subparamvalue !< subparam value to be used when defining new name character(len=fm_string_len) :: fm_yaml_null !< useful hack when OG subparam does not contain an equals sign integer :: current_field !< field index within loop @@ -614,14 +616,12 @@ subroutine read_field_table_yaml(nfields, table_name) return endif +! Construct my_table object +call build_fmTable(my_table, trim(tbl_name)) -! Define my_table object and read in number of fields -my_table = fmTable_t(trim(tbl_name)) -call my_table%get_blocks -call my_table%create_children -do h=1,my_table%nchildren - do i=1,my_table%children(h)%nchildren - do j=1,my_table%children(h)%children(i)%nchildren +do h=1,size(my_table%types) + do i=1,size(my_table%types(h)%models) + do j=1,size(my_table%types(h)%models(i)%variables) num_fields = num_fields + 1 end do end do @@ -630,9 +630,9 @@ subroutine read_field_table_yaml(nfields, table_name) allocate(fields(num_fields)) current_field = 0 -do h=1,my_table%nchildren - do i=1,my_table%children(h)%nchildren - select case (my_table%children(h)%children(i)%name) +do h=1,size(my_table%types) + do i=1,size(my_table%types(h)%models) + select case (my_table%types(h)%models(i)%name) case ('coupler_mod') model = MODEL_COUPLER case ('atmos_mod') @@ -645,58 +645,58 @@ subroutine read_field_table_yaml(nfields, table_name) model = MODEL_ICE case default call mpp_error(FATAL, trim(error_header)//'The model name is unrecognised : & - &'//trim(my_table%children(h)%children(i)%name)) + &'//trim(my_table%types(h)%models(i)%name)) end select - do j=1,my_table%children(h)%children(i)%nchildren + do j=1,size(my_table%types(h)%models(i)%variables) current_field = current_field + 1 - list_name = list_sep//lowercase(trim(my_table%children(h)%children(i)%name))//list_sep//& - lowercase(trim(my_table%children(h)%name))//list_sep//& - lowercase(trim(my_table%children(h)%children(i)%children(j)%name)) + list_name = list_sep//lowercase(trim(my_table%types(h)%models(i)%name))//list_sep//& + lowercase(trim(my_table%types(h)%name))//list_sep//& + lowercase(trim(my_table%types(h)%models(i)%variables(j)%name)) index_list_name = fm_new_list(list_name, create = .true.) if ( index_list_name == NO_FIELD ) & call mpp_error(FATAL, trim(error_header)//'Could not set field list for '//trim(list_name)) fm_success = fm_change_list(list_name) fields(current_field)%model = model - fields(current_field)%field_name = lowercase(trim(my_table%children(h)%children(i)%children(j)%name)) - fields(current_field)%field_type = lowercase(trim(my_table%children(h)%name)) - fields(current_field)%num_methods = size(my_table%children(h)%children(i)%children(j)%key_ids) + fields(current_field)%field_name = lowercase(trim(my_table%types(h)%models(i)%variables(j)%name)) + fields(current_field)%field_type = lowercase(trim(my_table%types(h)%name)) + fields(current_field)%num_methods = size(my_table%types(h)%models(i)%variables(j)%keys) allocate(fields(current_field)%methods(fields(current_field)%num_methods)) if(fields(current_field)%num_methods.gt.0) then - if (my_table%children(h)%children(i)%children(j)%nchildren .gt. 0) subparams = .true. - do k=1,size(my_table%children(h)%children(i)%children(j)%keys) + subparams = (size(my_table%types(h)%models(i)%variables(j)%attributes) .gt. 0) + do k=1,size(my_table%types(h)%models(i)%variables(j)%keys) fields(current_field)%methods(k)%method_type = & - lowercase(trim(my_table%children(h)%children(i)%children(j)%keys(k))) + lowercase(trim(my_table%types(h)%models(i)%variables(j)%keys(k))) fields(current_field)%methods(k)%method_name = & - lowercase(trim(my_table%children(h)%children(i)%children(j)%values(k))) + lowercase(trim(my_table%types(h)%models(i)%variables(j)%values(k))) if (.not.subparams) then - call new_name_yaml(list_name, my_table%children(h)%children(i)%children(j)%keys(k),& - my_table%children(h)%children(i)%children(j)%values(k) ) + call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),& + my_table%types(h)%models(i)%variables(j)%values(k) ) else subparamindex=-1 - do l=1,my_table%children(h)%children(i)%children(j)%nchildren - if(lowercase(trim(my_table%children(h)%children(i)%children(j)%children(l)%paramname)).eq.& + do l=1,size(my_table%types(h)%models(i)%variables(j)%attributes) + if(lowercase(trim(my_table%types(h)%models(i)%variables(j)%attributes(l)%paramname)).eq.& lowercase(trim(fields(current_field)%methods(k)%method_type))) then subparamindex = l exit end if end do if (subparamindex.eq.-1) then - call new_name_yaml(list_name, my_table%children(h)%children(i)%children(j)%keys(k),& - my_table%children(h)%children(i)%children(j)%values(k) ) + call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),& + my_table%types(h)%models(i)%variables(j)%values(k) ) else - do m=1,size(my_table%children(h)%children(i)%children(j)%children(subparamindex)%keys) + do m=1,size(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys) method_control = " " subparamvalue = " " - if (trim(my_table%children(h)%children(i)%children(j)%values(k)).eq.'fm_yaml_null') then + if (trim(my_table%types(h)%models(i)%variables(j)%values(k)).eq.'fm_yaml_null') then fm_yaml_null = '' else - fm_yaml_null = trim(my_table%children(h)%children(i)%children(j)%values(k))//'/' + fm_yaml_null = trim(my_table%types(h)%models(i)%variables(j)%values(k))//'/' end if - method_control = trim(my_table%children(h)%children(i)%children(j)%keys(k))//"/"//& + method_control = trim(my_table%types(h)%models(i)%variables(j)%keys(k))//"/"//& &trim(fm_yaml_null)//& - &trim(my_table%children(h)%children(i)%children(j)%children(subparamindex)%keys(m)) - subparamvalue = trim(my_table%children(h)%children(i)%children(j)%children(subparamindex)%values(m)) - call new_name_yaml(list_name, method_control, subparamvalue) + &trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys(m)) + subparamvalue = trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%values(m)) + call new_name(list_name, method_control, subparamvalue) end do end if end if @@ -707,7 +707,6 @@ subroutine read_field_table_yaml(nfields, table_name) end do if (present(nfields)) nfields = num_fields -call my_table%destruct end subroutine read_field_table_yaml !> @brief Subroutine to add new values to list parameters. @@ -860,7 +859,7 @@ subroutine read_field_table_legacy(nfields, table_name) character(len=1024) :: record character(len=fm_string_len) :: control_str -character(len=fm_path_name_len) :: list_name +character(len=FMS_PATH_LEN) :: list_name character(len=fm_string_len) :: method_name character(len=fm_string_len) :: name_str character(len=fm_string_len) :: type_str @@ -1908,8 +1907,8 @@ function find_list(path, relative_p, create) & type (field_def), pointer :: relative_p !< pointer to the list to which "path" is relative to logical, intent(in) :: create !< If the list does not exist, it will be created if set to true -character(len=fm_path_name_len) :: working_path -character(len=fm_path_name_len) :: rest +character(len=FMS_PATH_LEN) :: working_path +character(len=FMS_PATH_LEN) :: rest character(len=fm_field_name_len) :: this_list integer :: i, out_unit type (field_def), pointer, save :: working_path_p @@ -2175,7 +2174,7 @@ end function fm_get_index !> @returns The path corresponding to the current list function fm_get_current_list() & result (path) -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path type (field_def), pointer, save :: temp_list_p ! Initialize the field manager if needed @@ -2585,7 +2584,7 @@ function fm_new_list(name, create, keep) & logical :: create_t logical :: keep_t -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base type (field_def), pointer, save :: temp_list_p integer :: out_unit @@ -2655,7 +2654,7 @@ function fm_new_value_integer(name, new_ival, create, index, append) & integer :: i integer :: index_t integer, pointer, dimension(:) :: temp_i_value -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base type (field_def), pointer, save :: temp_list_p type (field_def), pointer, save :: temp_field_p @@ -2791,7 +2790,7 @@ function fm_new_value_logical(name, new_lval, create, index, append) & logical, intent(in), optional :: append !< If present and .true., then append the value to !! an array of the present values. If present and .true., then index cannot be greater than 0. -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base integer :: i integer :: index_t @@ -2925,7 +2924,7 @@ function fm_new_value_string(name, new_sval, create, index, append) & logical, intent(in), optional :: append !< If present and .true., then append the value to character(len=fm_string_len), dimension(:), pointer :: temp_s_value -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base integer :: i integer :: index_t @@ -3089,7 +3088,7 @@ function get_field(name, this_list_p) & type (field_def), pointer :: this_list_p !< A pointer to a list that serves as the base point !! for searching for name -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base type (field_def), pointer, save :: temp_p @@ -3125,7 +3124,7 @@ function fm_modify_name(oldname, newname) character(len=*), intent(in) :: newname !< The name that the user wishes to change the name of !! the field to. -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base type (field_def), pointer, save :: list_p type (field_def), pointer, save :: temp_p @@ -3266,9 +3265,9 @@ function fm_query_method(name, method_name, method_control) & character(len=*), intent(out) :: method_name !< name of a parameter associated with the named field character(len=*), intent(out) :: method_control !< value of parameters associated with the named field -character(len=fm_path_name_len) :: path -character(len=fm_path_name_len) :: base -character(len=fm_path_name_len) :: name_loc +character(len=FMS_PATH_LEN) :: path +character(len=FMS_PATH_LEN) :: base +character(len=FMS_PATH_LEN) :: name_loc logical :: recursive_t type (field_def), pointer, save :: temp_list_p type (field_def), pointer, save :: temp_value_p @@ -3574,7 +3573,7 @@ recursive function find_method(list_p, recursive, num_meth, method, control) & character(len=*), intent(out), dimension(:) :: method !< The methods associated with the field pointed to by list_p character(len=*), intent(out), dimension(:) :: control !< The control parameters for the methods found -character(len=fm_path_name_len) :: scratch +character(len=FMS_PATH_LEN) :: scratch integer :: i integer :: n type (field_def), pointer, save :: this_field_p diff --git a/field_manager/fm_util.F90 b/field_manager/fm_util.F90 index 41432ca9e3..c507d09095 100644 --- a/field_manager/fm_util.F90 +++ b/field_manager/fm_util.F90 @@ -28,14 +28,14 @@ !> @{ module fm_util_mod !{ -use field_manager_mod, only: fm_string_len, fm_path_name_len, fm_field_name_len, fm_type_name_len +use field_manager_mod, only: fm_string_len, fm_field_name_len, fm_type_name_len use field_manager_mod, only: fm_get_type, fm_get_index, fm_get_length use field_manager_mod, only: fm_get_current_list, fm_new_list, fm_change_list, fm_loop_over_list use field_manager_mod, only: fm_new_value, fm_get_value use field_manager_mod, only: fm_exists, fm_dump_list use fms_mod, only: FATAL, stdout use mpp_mod, only: mpp_error -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN implicit none @@ -93,9 +93,9 @@ module fm_util_mod !{ character(len=128) :: save_default_good_name_list = ' ' logical :: default_no_overwrite = .false. logical :: save_default_no_overwrite = .false. -character(len=fm_path_name_len) :: save_current_list -character(len=fm_path_name_len) :: save_path -character(len=fm_path_name_len) :: save_name +character(len=FMS_PATH_LEN) :: save_current_list +character(len=FMS_PATH_LEN) :: save_path +character(len=FMS_PATH_LEN) :: save_name ! Include variable "version" to be written to log file. #include @@ -1602,7 +1602,7 @@ subroutine fm_util_set_value_integer_array(name, ival, length, caller, no_overwr integer, intent(in) :: ival(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite -character(len=fm_path_name_len), intent(in), optional :: good_name_list +character(len=*), intent(in), optional :: good_name_list ! ! Local parameters @@ -1623,7 +1623,7 @@ subroutine fm_util_set_value_integer_array(name, ival, length, caller, no_overwr integer :: field_length integer :: n logical :: no_overwrite_use -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: add_name ! @@ -1759,7 +1759,7 @@ subroutine fm_util_set_value_logical_array(name, lval, length, caller, no_overwr logical, intent(in) :: lval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite -character(len=fm_path_name_len), intent(in), optional :: good_name_list +character(len=*), intent(in), optional :: good_name_list ! ! Local parameters @@ -1780,7 +1780,7 @@ subroutine fm_util_set_value_logical_array(name, lval, length, caller, no_overwr integer :: field_length integer :: n logical :: no_overwrite_use -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: add_name ! @@ -1916,7 +1916,7 @@ subroutine fm_util_set_value_string_array(name, sval, length, caller, no_overwri character(len=*), intent(in) :: sval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite -character(len=fm_path_name_len), intent(in), optional :: good_name_list +character(len=*), intent(in), optional :: good_name_list ! ! Local parameters @@ -1937,7 +1937,7 @@ subroutine fm_util_set_value_string_array(name, sval, length, caller, no_overwri integer :: field_length integer :: n logical :: no_overwrite_use -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: add_name ! @@ -2096,7 +2096,7 @@ subroutine fm_util_set_value_integer(name, ival, caller, index, append, no_creat integer :: field_index logical :: no_overwrite_use integer :: field_length -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: create logical :: add_name @@ -2268,7 +2268,7 @@ subroutine fm_util_set_value_logical(name, lval, caller, index, append, no_creat integer :: field_index logical :: no_overwrite_use integer :: field_length -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: create logical :: add_name @@ -2439,7 +2439,7 @@ subroutine fm_util_set_value_string(name, sval, caller, index, append, no_create integer :: field_index logical :: no_overwrite_use integer :: field_length -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: create logical :: add_name @@ -2600,7 +2600,7 @@ subroutine fm_util_start_namelist(path, name, caller, no_overwrite, check) !{ ! integer :: namelist_index -character(len=fm_path_name_len) :: path_name +character(len=FMS_PATH_LEN) :: path_name character(len=256) :: error_header character(len=256) :: warn_header character(len=256) :: note_header @@ -2764,7 +2764,7 @@ subroutine fm_util_end_namelist(path, name, caller, check) !{ ! character(len=fm_string_len), pointer, dimension(:) :: good_list => NULL() -character(len=fm_path_name_len) :: path_name +character(len=FMS_PATH_LEN) :: path_name character(len=256) :: error_header character(len=256) :: warn_header character(len=256) :: note_header diff --git a/field_manager/fm_yaml.F90 b/field_manager/fm_yaml.F90 index 32cc63cb1b..3dabc2d093 100644 --- a/field_manager/fm_yaml.F90 +++ b/field_manager/fm_yaml.F90 @@ -16,6 +16,7 @@ !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** + !> @defgroup fm_yaml_mod fm_yaml_mod !> @ingroup fm_yaml !> @brief Reads entries from a field table yaml into a @@ -31,493 +32,330 @@ !> @{ module fm_yaml_mod #ifdef use_yaml + use yaml_parser_mod +use mpp_mod, only: mpp_error, fatal implicit none private -integer :: i, table_i, type_i, model_i, var_i, var_j, attr_j !< counters - !> @} -! close documentation grouping -!> @brief This type represents the subparameters for a given variable parameter. -!> This type contains the name of the associated parameter, the key / value pairs for this subparameter, -!! and the following methods: getting names and properties, and self destruction. +public :: build_fmTable + +!> @brief This type represents a subparameter block for a given variable parameter. +!> This type contains the name of the associated parameter and the subparameter key/value pairs !> @ingroup fm_yaml_mod type, public :: fmAttr_t - integer :: yfid !< file id of a yaml file integer :: id !< block id of this var character(len=:), allocatable :: paramname !< name of associated parameter - character(len=:), dimension(:), allocatable :: keys !< name of the variable - character(len=:), dimension(:), allocatable :: values !< name of the variable - contains - procedure :: destruct => destruct_fmAttr_t - procedure :: get_names_and_props => get_name_fmAttr_t + character(len=:), dimension(:), allocatable :: keys !< name of the attribute + character(len=:), dimension(:), allocatable :: values !< value of the attribute end type fmAttr_t !> @brief This type represents the entries for a given variable, e.g. dust. -!> This type contains the name of the variable, the block id, the key / value pairs for this variable's parameters, -!! any applicable subparameters, and the following methods: -!! getting blocks, getting names and properties, creating children (subparameters), and self destruction. +!> This type contains the name of the variable, the block id, the key/value pairs for the +!> variable's parameters, and any applicable subparameters !> @ingroup fm_yaml_mod type, public :: fmVar_t - integer :: yfid !< file id of a yaml file integer :: id !< block id of this var character(len=:), allocatable :: name !< name of the variable - integer, dimension(:), allocatable :: key_ids !< key ids for params character(len=:), dimension(:), allocatable :: keys !< names of params character(len=:), dimension(:), allocatable :: values !< values of params - character(len=9) :: blockname="subparams" !< name of the root block - integer :: nchildren !< number of attributes - integer, allocatable :: child_ids(:) !< array of attribute ids - type (fmAttr_t), allocatable :: children(:) !< attributes in this var - contains - procedure :: get_blocks => get_blocks_fmVar_t - procedure :: destruct => destruct_fmVar_t - procedure :: get_names_and_props => get_name_fmVar_t - procedure :: create_children => create_children_fmVar_t + type (fmAttr_t), allocatable :: attributes(:) !< attributes in this var end type fmVar_t !> @brief This type represents the entries for a given model, e.g. land, ocean, atmosphere. -!> This type contains the name of the model, the block id, the variables within this model, -!! and the following methods: getting blocks, getting the name, creating children (variables), and self destruction. +!> This type contains the name of the model, the block id, and the variables within this model !> @ingroup fm_yaml_mod type, public :: fmModel_t - integer :: yfid !< file id of a yaml file integer :: id !< block id of this model character(len=:), allocatable :: name !< name of the model - character(len=7) :: blockname="varlist" !< name of the root block - integer :: nchildren !< number of var types - integer, allocatable :: child_ids(:) !< array of var ids - type (fmVar_t), allocatable :: children(:) !< variables in this model - contains - procedure :: get_blocks => get_blocks_fmModel_t - procedure :: destruct => destruct_fmModel_t - procedure :: get_name => get_name_fmModel_t - procedure :: create_children => create_children_fmModel_t + type (fmVar_t), allocatable :: variables(:) !< variables in this model end type fmModel_t !> @brief This type represents the entries for a specific field type, e.g. a tracer. -!> This type contains the name of the field type, the block id, the models within this field type, -!! and the following methods: getting blocks, getting the name, creating children (models), and self destruction. +!> This type contains the name of the field type, the block id, and the models within this field type !> @ingroup fm_yaml_mod type, public :: fmType_t - integer :: yfid !< file id of a yaml file integer :: id !< block id of this type character(len=:), allocatable :: name !< name of the type - character(len=7) :: blockname="modlist" !< name of the root block - integer :: nchildren !< number of model types - integer, allocatable :: child_ids(:) !< array of model ids - type (fmModel_t), allocatable :: children(:) !< models in this type - contains - procedure :: get_blocks => get_blocks_fmType_t - procedure :: destruct => destruct_fmType_t - procedure :: get_name => get_name_fmType_t - procedure :: create_children => create_children_fmType_t + type (fmModel_t), allocatable :: models(:) !< models in this type end type fmType_t -!> @brief This type represents the entirety of the field table. -!> This type contains the file id of the yaml file, the field types within this table, and the following methods: -!! getting blocks, creating children (field types), and self destruction. +!> @brief This type contains the field types within a field table. !> @ingroup fm_yaml_mod type, public :: fmTable_t - integer :: yfid !< file id of a yaml file - character(len=11) :: blockname="field_table" !< name of the root block - integer :: nchildren !< number of field types - integer, allocatable :: child_ids(:) !< array of type ids - type (fmType_t), allocatable :: children(:) !< field types in this table - contains - procedure :: get_blocks => get_blocks_fmTable_t - procedure :: destruct => destruct_fmTable_t - procedure :: create_children => create_children_fmTable_t + type (fmType_t), allocatable :: types(:) !< field types in this table end type fmTable_t -!> @brief Interface to construct the fmTable type. -!> @ingroup fm_yaml_mod -interface fmTable_t - module procedure construct_fmTable_t -end interface fmTable_t - -!> @brief Interface to construct the fmType type. -!> @ingroup fm_yaml_mod -interface fmType_t - module procedure construct_fmType_t -end interface fmType_t - -!> @brief Interface to construct the fmModel type. -!> @ingroup fm_yaml_mod -interface fmModel_t - module procedure construct_fmModel_t -end interface fmModel_t - -!> @brief Interface to construct the fmVar type. -!> @ingroup fm_yaml_mod -interface fmVar_t - module procedure construct_fmVar_t -end interface fmVar_t - -!> @brief Interface to construct the fmAttr type. -!> @ingroup fm_yaml_mod -interface fmAttr_t - module procedure construct_fmAttr_t -end interface fmAttr_t - contains !> @addtogroup fm_yaml_mod !> @{ -!> @brief Function to construct the fmTable_t type. -!! -!> Given an optional filename, construct the fmTable type using routines from the yaml parser. -!! @returns the fmTable type -function construct_fmTable_t(filename) result(this) - type (fmTable_t) :: this !< the field table +!> @brief Subroutine to populate an fmTable by reading a yaml file, given an optional filename. +subroutine build_fmTable(fmTable, filename) + type(fmTable_t), intent(out) :: fmTable !< the field table character(len=*), intent(in), optional :: filename !< the name of the yaml file + integer :: yfid !< file id of the yaml file + integer :: ntypes !< number of field types attached to this table + integer :: i !< Loop counter if (.not. present(filename)) then - this%yfid = open_and_parse_file("field_table.yaml") + yfid = open_and_parse_file("field_table.yaml") else - this%yfid = open_and_parse_file(trim(filename)) + yfid = open_and_parse_file(trim(filename)) endif - this%nchildren = get_num_blocks(this%yfid, this%blockname) - allocate(this%child_ids(this%nchildren)) -end function construct_fmTable_t -!> @brief Function to construct the fmType_t type. -!! -!> Given the appropriate block id, construct the fmType type using routines from the yaml parser. -!! @returns the fmType type -function construct_fmType_t(in_yfid, in_id) result(this) - type (fmType_t) :: this !< the type object - integer, intent(in) :: in_yfid !< yaml file id - integer, intent(in) :: in_id !< block_id of type from parent - - this%yfid = in_yfid - this%id = in_id - this%nchildren = get_num_blocks(this%yfid, this%blockname, this%id) - allocate(this%child_ids(this%nchildren)) -end function construct_fmType_t - -!> @brief Function to construct the fmModel_t type. -!! -!> Given the appropriate block id, construct the fmModel type using routines from the yaml parser. -!! @returns the fmModel type -function construct_fmModel_t(in_yfid, in_id) result(this) - type (fmModel_t) :: this !< the model object - integer, intent(in) :: in_yfid !< yaml file id - integer, intent(in) :: in_id !< block_id of model from parent - - this%yfid = in_yfid - this%id = in_id - this%nchildren = get_num_blocks(this%yfid, this%blockname, this%id) - allocate(this%child_ids(this%nchildren)) -end function construct_fmModel_t - -!> @brief Function to construct the fmVar_t type. -!! -!> Given the appropriate block id, construct the fmVar type using routines from the yaml parser. -!! @returns the fmVar type -function construct_fmVar_t(in_yfid, in_id) result(this) - type (fmVar_t) :: this !< the var object - integer, intent(in) :: in_yfid !< yaml file id - integer, intent(in) :: in_id !< block_id of var from parent - - this%yfid = in_yfid - this%id = in_id - this%nchildren = get_num_blocks(this%yfid, this%blockname, this%id) - allocate(this%child_ids(this%nchildren)) -end function construct_fmVar_t - -!> @brief Function to construct the fmAttr_t type. -!! -!> Given the appropriate block id, construct the fmAttr type using routines from the yaml parser. -!! @returns the fmAttr type -function construct_fmAttr_t(in_yfid, in_id) result(this) - type (fmAttr_t) :: this !< the var object - integer, intent(in) :: in_yfid !< yaml file id - integer, intent(in) :: in_id !< block_id of var from parent - - this%yfid = in_yfid - this%id = in_id -end function construct_fmAttr_t - -!> @brief Subroutine to destruct the fmTable_t type. -!! -!> Deallocates this type's allocatables and calls the destruct routine for this type's children. -subroutine destruct_fmTable_t(this) - class (fmTable_t) :: this !< the field table - - if (allocated(this%child_ids)) deallocate(this%child_ids) - if (allocated(this%children)) then - do table_i=1,this%nchildren - call destruct_fmType_t(this%children(table_i)) - end do - end if - if (allocated(this%children)) deallocate(this%children) -end subroutine destruct_fmTable_t - -!> @brief Subroutine to destruct the fmType_t type. -!! -!> Deallocates this type's allocatables and calls the destruct routine for this type's children. -subroutine destruct_fmType_t(this) - class (fmType_t) :: this !< type object - - if (allocated(this%name)) deallocate(this%name) - if (allocated(this%child_ids)) deallocate(this%child_ids) - if (allocated(this%children)) then - do type_i=1,this%nchildren - call destruct_fmModel_t(this%children(type_i)) - end do - end if - if (allocated(this%children)) deallocate(this%children) -end subroutine destruct_fmType_t - -!> @brief Subroutine to destruct the fmModel_t type. -!! -!> Deallocates this type's allocatables and calls the destruct routine for this type's children. -subroutine destruct_fmModel_t(this) - class (fmModel_t) :: this !< model object - - if (allocated(this%name)) deallocate(this%name) - if (allocated(this%child_ids)) deallocate(this%child_ids) - if (allocated(this%children)) then - do model_i=1,this%nchildren - call destruct_fmVar_t(this%children(model_i)) - end do - end if - if (allocated(this%children)) deallocate(this%children) -end subroutine destruct_fmModel_t - -!> @brief Subroutine to destruct the fmVar_t type. -!! -!> Deallocates this type's allocatables and calls the destruct routine for this type's children. -subroutine destruct_fmVar_t(this) - class (fmVar_t) :: this !< variable object - - if (allocated(this%name)) deallocate(this%name) - if (allocated(this%key_ids)) deallocate(this%key_ids) - if (allocated(this%keys)) deallocate(this%keys) - if (allocated(this%values)) deallocate(this%values) - if (allocated(this%child_ids)) deallocate(this%child_ids) - if (allocated(this%children)) then - do var_i=1,this%nchildren - call destruct_fmAttr_t(this%children(var_i)) - end do - end if - if (allocated(this%children)) deallocate(this%children) -end subroutine destruct_fmVar_t - -!> @brief Subroutine to destruct the fmAttr_t type. -!! -!> Deallocates this type's allocatables. -subroutine destruct_fmAttr_t(this) - class (fmAttr_t) :: this !< variable object - - if (allocated(this%paramname)) deallocate(this%paramname) - if (allocated(this%keys)) deallocate(this%keys) - if (allocated(this%values)) deallocate(this%values) -end subroutine destruct_fmAttr_t - -!> @brief gets the block ids for children of this type. -subroutine get_blocks_fmTable_t(this) - class (fmTable_t) :: this !< field table object - - call get_block_ids(this%yfid, this%blockname, this%child_ids) -end subroutine get_blocks_fmTable_t - -!> @brief gets the block ids for children of this type. -subroutine get_blocks_fmType_t(this) - class (fmType_t) :: this !< type object - - call get_block_ids(this%yfid, this%blockname, this%child_ids, this%id) -end subroutine get_blocks_fmType_t - -!> @brief Gets the name of this field type and adds it to the fmType_t. -!! Note that there should only be one key value pair (which is why the get_key_value call uses key_ids(1)). -subroutine get_name_fmType_t(this) - class (fmType_t) :: this !< type object - integer :: nkeys !< numkeys - integer, allocatable :: key_ids(:) !< array of key ids - character(len=256) :: key_value !< the value of a key - - nkeys = get_nkeys(this%yfid, this%id) - allocate(key_ids(nkeys)) - call get_key_ids(this%yfid, this%id, key_ids) - call get_key_value(this%yfid, key_ids(1), key_value) - this%name = trim(key_value) -end subroutine get_name_fmType_t - -!> @brief gets the block ids for children of this type. -subroutine get_blocks_fmModel_t(this) - class (fmModel_t) :: this !< model object - - call get_block_ids(this%yfid, this%blockname, this%child_ids, this%id) -end subroutine get_blocks_fmModel_t - -!> @brief Gets the name of this model and adds it to the fmModel_t. -!! Note that there should only be one key value pair (which is why the get_key_value call uses key_ids(1)). -subroutine get_name_fmModel_t(this) - class (fmModel_t) :: this !< model object - integer :: nkeys !< numkeys - integer, allocatable :: key_ids(:) !< array of key ids - character(len=256) :: key_value !< the value of a key - - nkeys = get_nkeys(this%yfid, this%id) - allocate(key_ids(nkeys)) - call get_key_ids(this%yfid, this%id, key_ids) - call get_key_value(this%yfid, key_ids(1), key_value) - this%name = trim(key_value) -end subroutine get_name_fmModel_t - -!> @brief gets the block ids for children of this type. -subroutine get_blocks_fmVar_t(this) - class (fmVar_t) :: this !< variable object - - call get_block_ids(this%yfid, this%blockname, this%child_ids, this%id) -end subroutine get_blocks_fmVar_t - -!> @brief Gets the name of this variable as well as the associated parameters and adds them to fmVar_t. -!! Note that the length of the character arrays for the parameter names and values are allocatable. -!! This is why they are read twice. -subroutine get_name_fmVar_t(this) - class (fmVar_t) :: this !< variable object - integer :: nkeys !< numkeys - integer :: maxln !< max string length names - integer :: maxlv !< max string length values - integer, allocatable :: key_ids(:) !< array of key ids - character(len=256) :: key_name !< the name of a key - character(len=256) :: key_value !< the value of a key - - nkeys = get_nkeys(this%yfid, this%id) + ntypes = get_num_blocks(yfid, "field_table", 0) + allocate(fmTable%types(ntypes)) + + ! Gets the block ids for the associated types of fmTable. + call get_block_ids(yfid, "field_table", fmTable%types(:)%id) + + do i=1,ntypes + call build_fmType(fmTable%types(i), yfid) + enddo +end subroutine build_fmTable + +!> @brief Populates an fmType, which is assumed to already have its `id` parameter set. +subroutine build_fmType(fmType, yfid) + type(fmType_t), intent(inout) :: fmType !< type object + integer, intent(in) :: yfid !< file id of the yaml file + integer, dimension(1) :: key_ids !< array of key ids + character(len=256) :: key_name !< the name of a key + character(len=256) :: key_value !< the value of a key + integer :: nmodels !< number of models attached to this type + integer :: i !< Loop counter + + nmodels = get_num_blocks(yfid, "modlist", fmType%id) + allocate(fmType%models(nmodels)) + + ! Gets the block ids for the associated models of fmType. + call get_block_ids(yfid, "modlist", fmType%models(:)%id, fmType%id) + + if (get_nkeys(yfid, fmType%id).ne.1) then + call mpp_error(FATAL, "fm_yaml_mod: A single `field_type` key is expected") + endif + + call get_key_ids(yfid, fmType%id, key_ids) + call get_key_name(yfid, key_ids(1), key_name) + call get_key_value(yfid, key_ids(1), key_value) + + if (trim(key_name).ne."field_type") then + call mpp_error(FATAL, "fm_yaml_mod: A single `field_type` key is expected") + endif + + fmType%name = trim(key_value) + + do i=1,nmodels + call build_fmModel(fmType%models(i), yfid) + enddo +end subroutine build_fmType + +!> @brief Populates an fmModel, which is assumed to already have its `id` parameter set. +subroutine build_fmModel(fmModel, yfid) + type(fmModel_t), intent(inout) :: fmModel !< model object + integer, intent(in) :: yfid !< file id of the yaml file + integer, dimension(1) :: key_ids !< array of key ids + character(len=256) :: key_name !< the name of a key + character(len=256) :: key_value !< the value of a key + integer :: nvars !< number of variables attached to this model + integer :: i !< Loop counter + + nvars = get_num_blocks(yfid, "varlist", fmModel%id) + allocate(fmModel%variables(nvars)) + + ! gets the block ids for the associated variables of fmModel. + call get_block_ids(yfid, "varlist", fmModel%variables(:)%id, fmModel%id) + + if (get_nkeys(yfid, fmModel%id).ne.1) then + call mpp_error(FATAL, "fm_yaml_mod: A single `model_type` key is expected") + endif + + call get_key_ids(yfid, fmModel%id, key_ids) + call get_key_name(yfid, key_ids(1), key_name) + call get_key_value(yfid, key_ids(1), key_value) + + if (trim(key_name).ne."model_type") then + call mpp_error(FATAL, "fm_yaml_mod: A single `model_type` key is expected") + endif + + fmModel%name = trim(key_value) + + do i=1,nvars + call build_fmVar(fmModel%variables(i), yfid) + enddo +end subroutine build_fmModel + +!> @brief Populates an fmVar and creates any associated fmAttrs +subroutine build_fmVar(fmVar, yfid) + type(fmVar_t), intent(inout) :: fmVar !< variable object + integer, intent(in) :: yfid !< file id of the yaml file + integer :: nkeys !< number of keys defined for this var + integer, allocatable :: key_ids(:) !< array of key ids + character(len=256) :: key_name !< the name of a key + character(len=256) :: key_value !< the value of a key + integer :: nattrs !< number of attribute blocks attached to this var + integer :: nmethods !< total number of methods attached to this var + integer :: maxln !< max string length of method names + integer :: maxlv !< max string length of method values + character(:), allocatable :: attr_method_keys(:) !< Keys of methods defined in attribute blocks + character(:), allocatable :: attr_method_values(:) !< Values of methods defined in attribute blocks + integer :: i_name !< Index of the key containing the variable's name + integer :: i, j !< Loop indices + + ! Read attribute blocks attached to this variable + call fmVar_read_attrs(fmVar, yfid, attr_method_keys, attr_method_values) + nattrs = size(attr_method_keys) + + nkeys = get_nkeys(yfid, fmVar%id) allocate(key_ids(nkeys)) - call get_key_ids(this%yfid, this%id, key_ids) - call get_key_value(this%yfid, key_ids(1), key_value) - this%name = trim(key_value) - if (nkeys .gt. 1) then - maxln = 0 - maxlv = 0 - do var_j=2,nkeys - call get_key_name(this%yfid, key_ids(var_j), key_name) - call get_key_value(this%yfid, key_ids(var_j), key_value) + call get_key_ids(yfid, fmVar%id, key_ids) + + maxln = len(attr_method_keys) + maxlv = len(attr_method_values) + i_name = -1 + + do i=1,nkeys + call get_key_name(yfid, key_ids(i), key_name) + call get_key_value(yfid, key_ids(i), key_value) + + if (trim(key_name) .eq. "variable") then + if (i_name .ne. -1) then + call mpp_error(FATAL, "fm_yaml_mod: A variable can have only one `variable` key") + endif + + fmVar%name = trim(key_value) + i_name = i + else maxln = max(maxln, len_trim(key_name)) maxlv = max(maxlv, len_trim(key_value)) - end do - allocate(this%key_ids(nkeys-1)) - allocate(character(len=maxln)::this%keys(nkeys-1)) - allocate(character(len=maxlv)::this%values(nkeys-1)) - do var_j=2,nkeys - this%key_ids(var_j-1) = key_ids(var_j) - call get_key_name(this%yfid, key_ids(var_j), key_name) - call get_key_value(this%yfid, key_ids(var_j), key_value) - this%keys(var_j-1) = trim(key_name) - this%values(var_j-1) = trim(key_value) - end do - else - allocate(this%key_ids(0)) - end if -end subroutine get_name_fmVar_t - -!> @brief Gets the name of the parameter and the key value pairs for the subparameters and adds them to fmAttr_t. -!! Note that the length of the character arrays for the subparameter names and values are allocatable. -!! This is why they are read twice. -subroutine get_name_fmAttr_t(this) - class (fmAttr_t) :: this !< variable object - integer :: nkeys !< numkeys - integer :: maxln !< max string length names - integer :: maxlv !< max string length values - integer, allocatable :: key_ids(:) !< array of key ids - character(len=256) :: key_name !< the name of a key - character(len=256) :: key_value !< the value of a key - character(len=256) :: paramname !< the value of a key - - call get_key_name(this%yfid, this%id-1, paramname) - allocate(character(len=len_trim(paramname))::this%paramname) - this%paramname = trim(paramname) - nkeys = get_nkeys(this%yfid, this%id) - allocate(key_ids(nkeys)) - call get_key_ids(this%yfid, this%id, key_ids) - maxln = 0 - maxlv = 0 - do attr_j=1,nkeys - call get_key_name(this%yfid, key_ids(attr_j), key_name) - call get_key_value(this%yfid, key_ids(attr_j), key_value) - maxln = max(maxln, len_trim(key_name)) - maxlv = max(maxlv, len_trim(key_value)) - end do - allocate(character(len=maxln)::this%keys(nkeys)) - allocate(character(len=maxlv)::this%values(nkeys)) - do attr_j=1,nkeys - call get_key_name(this%yfid, key_ids(attr_j), key_name) - call get_key_value(this%yfid, key_ids(attr_j), key_value) - this%keys(attr_j) = trim(key_name) - this%values(attr_j) = trim(key_value) - end do -end subroutine get_name_fmAttr_t - -!> @brief Creates the children (fmType_t) of this type (fmTable_t). -!! -!! Note that this includes the creation function as well as the routines necessary to populate the child type, -!! including calling the create_children routine for the child type (this makes it somewhat recursive). -subroutine create_children_fmTable_t(this) - class (fmTable_t) :: this !< the field table - - allocate(this%children(this%nchildren)) - do table_i=1,this%nchildren - this%children(table_i) = fmType_t(this%yfid, this%child_ids(table_i)) - call this%children(table_i)%get_blocks - call this%children(table_i)%get_name - call this%children(table_i)%create_children - end do -end subroutine create_children_fmTable_t - -!> @brief Creates the children (fmModel_t) of this type (fmType_t). -!! -!! Note that this includes the creation function as well as the routines necessary to populate the child type, -!! including calling the create_children routine for the child type (this makes it somewhat recursive). -subroutine create_children_fmType_t(this) - class (fmType_t) :: this !< type object - - allocate(this%children(this%nchildren)) - do type_i=1,this%nchildren - this%children(type_i) = fmModel_t(this%yfid, this%child_ids(type_i)) - call this%children(type_i)%get_blocks - call this%children(type_i)%get_name - call this%children(type_i)%create_children - end do -end subroutine create_children_fmType_t - -!> @brief Creates the children (fmVar_t) of this type (fmModel_t). -!! -!! Note that this includes the creation function as well as the routines necessary to populate the child type, -!! including calling the create_children routine for the child type (this makes it somewhat recursive). -subroutine create_children_fmModel_t(this) - class (fmModel_t) :: this !< model object - - allocate(this%children(this%nchildren)) - do model_i=1,this%nchildren - this%children(model_i) = fmVar_t(this%yfid, this%child_ids(model_i)) - call this%children(model_i)%get_blocks - call this%children(model_i)%get_names_and_props - call this%children(model_i)%create_children - end do -end subroutine create_children_fmModel_t - -!> @brief Creates the children (fmAttr_t) of this type (fmVar_t). -!! -!! Note that this includes the creation function as well as the routines necessary to populate the child type. -subroutine create_children_fmVar_t(this) - class (fmVar_t) :: this !< var object - - if (this%nchildren .gt. 0) then - allocate(this%children(this%nchildren)) - do var_i=1,this%nchildren - this%children(var_i) = fmAttr_t(this%yfid, this%child_ids(var_i)) - call this%children(var_i)%get_names_and_props - end do - end if -end subroutine create_children_fmVar_t + endif + enddo + + if (i_name .eq. -1) then + call mpp_error(FATAL, "fm_yaml_mod: Every variable must have a `variable` key") + endif + + ! Number of methods is the number of keys (excluding `variable`), plus one for each attribute block. + nmethods = nkeys - 1 + nattrs + + allocate(character(len=maxln)::fmVar%keys(nmethods)) + allocate(character(len=maxlv)::fmVar%values(nmethods)) + + j = 1 + do i=1,nkeys + if (i.eq.i_name) cycle ! Exclude `variable` key + + call get_key_name(yfid, key_ids(i), key_name) + call get_key_value(yfid, key_ids(i), key_value) + fmVar%keys(j) = trim(key_name) + fmVar%values(j) = trim(key_value) + + j = j + 1 + enddo + + ! Add methods defined within attribute blocks. + fmVar%keys(j:) = attr_method_keys + fmVar%values(j:) = attr_method_values +end subroutine build_fmVar + +!> @brief Reads the attribute blocks attached to a variable and populates the associated fmAttr structures. +!! Returns two arrays containing key/value pairs of all methods defined via attribute blocks. +subroutine fmVar_read_attrs(fmVar, yfid, method_keys, method_values) + type(fmVar_t), intent(inout) :: fmVar !< variable object + integer, intent(in) :: yfid !< file id of the yaml file + character(:), allocatable, intent(out) :: method_keys(:) !< Method keys (names of attribute blocks) + character(:), allocatable, intent(out) :: method_values(:) !< Method values from attribute blocks + integer :: nattrs !< number of attribute blocks + integer :: nkeys !< number of keys in an attribute block + integer, allocatable :: key_ids(:) !< array of key ids + character(len=256) :: key_name !< the name of a key + character(len=256) :: key_value !< the value of a key + integer :: maxln_m !< max string length of method names + integer :: maxlv_m !< max string length of method values + integer :: maxln_a !< max string length of subparameter names + integer :: maxlv_a !< max string length of subparameter values + integer,allocatable :: name_key_id(:) !< Indices of attribute `value` keys + integer :: i, j, k !< Loop counters + + nattrs = get_num_unique_blocks(yfid, fmVar%id) + allocate(fmVar%attributes(nattrs)) + allocate(name_key_id(nattrs)) + + ! gets the block ids for the associated attributes of fmVar. + call get_unique_block_ids(yfid, fmVar%attributes(:)%id, fmVar%id) + + maxln_m = 0 + maxlv_m = 0 + name_key_id = -1 + + do i=1,nattrs + associate (fmAttr => fmVar%attributes(i)) + call get_block_name(yfid, fmAttr%id, key_value) + fmAttr%paramname = trim(key_value) + + nkeys = get_nkeys(yfid, fmAttr%id) + allocate(key_ids(nkeys)) + call get_key_ids(yfid, fmAttr%id, key_ids) + + maxln_a = 0 + maxlv_a = 0 + + do j=1,nkeys + call get_key_name(yfid, key_ids(j), key_name) + call get_key_value(yfid, key_ids(j), key_value) + + if (trim(key_name) .eq. "value") then + if (name_key_id(i) .ne. -1) then + call mpp_error(FATAL, "fm_yaml_mod: A variable attribute block can only have one `value` key") + endif + + maxln_m = max(maxln_m, len(fmAttr%paramname)) + maxlv_m = max(maxlv_m, len_trim(key_value)) + + name_key_id(i) = key_ids(j) + else + maxln_a = max(maxln_a, len_trim(key_name)) + maxlv_a = max(maxlv_a, len_trim(key_value)) + endif + enddo + + if (name_key_id(i) .eq. -1) then + call mpp_error(FATAL, "fm_yaml_mod: Every variable attribute must have a `value` key") + endif + + allocate(character(len=maxln_a)::fmAttr%keys(nkeys - 1)) + allocate(character(len=maxlv_a)::fmAttr%values(nkeys - 1)) + + k = 1 + do j=1,nkeys + if (key_ids(j).eq.name_key_id(i)) cycle + + call get_key_name(yfid, key_ids(j), key_name) + call get_key_value(yfid, key_ids(j), key_value) + fmAttr%keys(k) = trim(key_name) + fmAttr%values(k) = trim(key_value) + + k = k + 1 + enddo + + deallocate(key_ids) + end associate + enddo + + allocate(character(len=maxln_m)::method_keys(nattrs)) + allocate(character(len=maxlv_m)::method_values(nattrs)) + + do i=1,nattrs + method_keys(i) = fmVar%attributes(i)%paramname + call get_key_value(yfid, name_key_id(i), method_values(i)) + enddo +end subroutine fmVar_read_attrs + #endif end module fm_yaml_mod + !> @} ! close documentation grouping diff --git a/field_manager/include/field_manager.inc b/field_manager/include/field_manager.inc index e39cf2d7a9..c462152c7f 100644 --- a/field_manager/include/field_manager.inc +++ b/field_manager/include/field_manager.inc @@ -117,7 +117,7 @@ logical :: create_t integer :: i integer :: index_t real(r8_kind), allocatable, dimension(:) :: temp_r_value -character(len=fm_path_name_len) :: path +character(len=FMS_PATH_LEN) :: path character(len=fm_field_name_len) :: base type (field_def), pointer, save :: temp_list_p type (field_def), pointer, save :: temp_field_p diff --git a/field_manager/include/fm_util.inc b/field_manager/include/fm_util.inc index 26066ca868..6102532e96 100644 --- a/field_manager/include/fm_util.inc +++ b/field_manager/include/fm_util.inc @@ -36,7 +36,7 @@ integer, intent(in) :: length real(FMS_FM_KIND_), intent(in) :: rval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite -character(len=fm_path_name_len), intent(in), optional :: good_name_list +character(len=FMS_PATH_LEN), intent(in), optional :: good_name_list ! ! Local parameters @@ -57,7 +57,7 @@ integer :: field_index integer :: field_length integer :: n logical :: no_overwrite_use -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: add_name integer, parameter :: lkind=FMS_FM_KIND_ @@ -218,7 +218,7 @@ character(len=32) :: str_error integer :: field_index logical :: no_overwrite_use integer :: field_length -character(len=fm_path_name_len) :: good_name_list_use +character(len=FMS_PATH_LEN) :: good_name_list_use logical :: create logical :: add_name diff --git a/fms2_io/blackboxio.F90 b/fms2_io/blackboxio.F90 index 4c5c6c3fb0..f7d26eb3d2 100644 --- a/fms2_io/blackboxio.F90 +++ b/fms2_io/blackboxio.F90 @@ -66,9 +66,9 @@ subroutine get_new_filename(path, new_path, directory, timestamp, new_name) character(len=*), intent(in), optional :: timestamp !< Time. character(len=*), intent(in), optional :: new_name !< New file basename. - character(len=256) :: dir - character(len=256) :: tstamp - character(len=256) :: nname + character(len=FMS_PATH_LEN) :: dir + character(len=FMS_FILE_LEN) :: tstamp + character(len=FMS_PATH_LEN) :: nname dir = "" if (present(directory)) then @@ -392,7 +392,7 @@ subroutine netcdf_save_restart_wrap2(fileobj, unlim_dim_level, directory, timest !! or "netcdf4". Defaults to !! "64bit". - character(len=256) :: new_name + character(len=FMS_PATH_LEN) :: new_name type(FmsNetcdfFile_t), target :: new_fileobj type(FmsNetcdfFile_t), pointer :: p logical :: close_new_file @@ -425,7 +425,7 @@ subroutine netcdf_restore_state_wrap(fileobj, unlim_dim_level, directory, timest character(len=*), intent(in), optional :: timestamp !< Model time. character(len=*), intent(in), optional :: filename !< New name for the file. - character(len=256) :: new_name + character(len=FMS_PATH_LEN) :: new_name type(FmsNetcdfFile_t), target :: new_fileobj type(FmsNetcdfFile_t), pointer :: p logical :: close_new_file @@ -534,7 +534,7 @@ subroutine save_domain_restart_wrap(fileobj, unlim_dim_level, directory, timesta !! or "netcdf4". Defaults to !! "64bit". - character(len=256) :: new_name + character(len=FMS_PATH_LEN) :: new_name type(FmsNetcdfDomainFile_t), target :: new_fileobj type(FmsNetcdfDomainFile_t), pointer :: p logical :: close_new_file @@ -567,7 +567,7 @@ subroutine restore_domain_state_wrap(fileobj, unlim_dim_level, directory, timest character(len=*), intent(in), optional :: filename !< New name for the file. logical, intent(in), optional :: ignore_checksum !< Checksum data integrity flag. - character(len=256) :: new_name + character(len=FMS_PATH_LEN) :: new_name type(FmsNetcdfDomainFile_t), target :: new_fileobj type(FmsNetcdfDomainFile_t), pointer :: p logical :: close_new_file diff --git a/fms2_io/fms_io_utils.F90 b/fms2_io/fms_io_utils.F90 index cd72c0c8d5..85b34aa840 100644 --- a/fms2_io/fms_io_utils.F90 +++ b/fms2_io/fms_io_utils.F90 @@ -678,7 +678,8 @@ subroutine get_mosaic_tile_file_sg(file_in, file_out, is_no_domain, domain, tile type(domain2D), intent(in), optional, target :: domain !< domain provided integer, intent(in), optional :: tile_count !< tile count - character(len=256) :: basefile, tilename + character(len=FMS_FILE_LEN) :: basefile + character(len=6) :: tilename character(len=2) :: my_tile_str integer :: lens, ntiles, ntileMe, tile, my_tile_id integer, dimension(:), allocatable :: tile_id @@ -735,7 +736,8 @@ subroutine get_mosaic_tile_file_ug(file_in, file_out, domain) character(len=*), intent(out) :: file_out !< name of tile file type(domainUG), intent(in), optional :: domain !< domain provided - character(len=256) :: basefile, tilename + character(len=FMS_FILE_LEN) :: basefile + character(len=6) :: tilename character(len=2) :: my_tile_str integer :: lens, ntiles, my_tile_id diff --git a/fms2_io/fms_netcdf_domain_io.F90 b/fms2_io/fms_netcdf_domain_io.F90 index f592bd24c7..ab58224d0c 100644 --- a/fms2_io/fms_netcdf_domain_io.F90 +++ b/fms2_io/fms_netcdf_domain_io.F90 @@ -65,7 +65,7 @@ module fms_netcdf_domain_io_mod !! with the "y" axis !! of a 2d domain. integer :: ny !< Number of "y" dimensions. - character(len=256) :: non_mangled_path !< Non-domain-mangled file path. + character(len=FMS_PATH_LEN) :: non_mangled_path !< Non-domain-mangled file path. logical :: adjust_indices !< Flag telling if indices need to be adjusted !! for domain-decomposed read. endtype FmsNetcdfDomainFile_t @@ -346,9 +346,9 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do integer, dimension(2) :: io_layout integer, dimension(1) :: tile_id - character(len=256) :: combined_filepath + character(len=FMS_PATH_LEN) :: combined_filepath type(domain2d), pointer :: io_domain - character(len=256) :: distributed_filepath + character(len=FMS_PATH_LEN) :: distributed_filepath integer :: pelist_size integer, dimension(:), allocatable :: pelist logical :: success2 diff --git a/fms2_io/fms_netcdf_unstructured_domain_io.F90 b/fms2_io/fms_netcdf_unstructured_domain_io.F90 index ad6ef199b7..408edb9f7d 100644 --- a/fms2_io/fms_netcdf_unstructured_domain_io.F90 +++ b/fms2_io/fms_netcdf_unstructured_domain_io.F90 @@ -27,6 +27,7 @@ module fms_netcdf_unstructured_domain_io_mod use mpp_domains_mod use fms_io_utils_mod use netcdf_io_mod +use platform_mod implicit none private @@ -34,7 +35,7 @@ module fms_netcdf_unstructured_domain_io_mod !> @ingroup fms_netcdf_unstructured_domain_io_mod type, public, extends(FmsNetcdfFile_t) :: FmsNetcdfUnstructuredDomainFile_t type(domainug) :: domain !< Unstructured domain. - character(len=256) :: non_mangled_path !< Non-domain-mangled path. + character(len=FMS_PATH_LEN) :: non_mangled_path !< Non-domain-mangled path. endtype FmsNetcdfUnstructuredDomainFile_t !> @addtogroup fms_netcdf_unstructured_domain_io_mod @@ -94,8 +95,8 @@ function open_unstructured_domain_file(fileobj, path, mode, domain, nc_format, & type(domainug), pointer :: io_domain integer :: pelist_size integer, dimension(:), allocatable :: pelist - character(len=256) :: buf - character(len=256) :: buf2 + character(len=FMS_PATH_LEN) :: buf + character(len=FMS_PATH_LEN) :: buf2 integer :: tile_id !Get the input domain's I/O domain pelist. diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 962076d5a5..e9396211f1 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -126,7 +126,7 @@ module netcdf_io_mod !> @brief Netcdf file type. !> @ingroup netcdf_io_mod type, public :: FmsNetcdfFile_t - character(len=256) :: path !< File path. + character(len=FMS_PATH_LEN) :: path !< File path. logical :: is_readonly !< Flag telling if the file is readonly. integer :: ncid !< Netcdf file id. character(len=256) :: nc_format !< Netcdf file format. @@ -569,8 +569,8 @@ function netcdf_file_open(fileobj, path, mode, nc_format, pelist, is_restart, do integer :: err integer :: netcdf4 !< Query the file for the _IsNetcdf4 global attribute in the event !! that the open for collective reads fails - character(len=256) :: buf !< Filename with .res in the filename if it is a restart - character(len=256) :: buf2 !< Filename with the filename appendix if there is one + character(len=FMS_PATH_LEN) :: buf !< File path with .res in the filename if it is a restart + character(len=FMS_PATH_LEN) :: buf2 !< File path with the filename appendix if there is one logical :: is_res logical :: dont_add_res !< flag indicated to not add ".res" to the filename @@ -1090,8 +1090,8 @@ subroutine netcdf_save_restart(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("write_restart:: file "//trim(fileobj%path)//" is not a restart file."& - &" Be sure the file was opened with is_restart=.true.") + call error("write_restart:: file "//trim(fileobj%path)//" is not a restart file. & + &Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then @@ -1132,8 +1132,8 @@ subroutine netcdf_restore_state(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("read_restart:: file "//trim(fileobj%path)//" is not a restart file."& - &" Be sure the file was opened with is_restart=.true.") + call error("read_restart:: file "//trim(fileobj%path)//" is not a restart file. & + &Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then @@ -1283,8 +1283,8 @@ subroutine get_dimension_names(fileobj, names, broadcast) ndims = get_num_dimensions(fileobj, broadcast=.false.) if (ndims .gt. 0) then if (size(names) .ne. ndims) then - call error("'names' has to be the same size of the number of dimensions."& - &" Check your get_dimension_names call for file "//trim(fileobj%path)) + call error("'names' has to be the same size of the number of dimensions. & + &Check your get_dimension_names call for file "//trim(fileobj%path)) endif else call error("get_dimension_names: the file "//trim(fileobj%path)//" does not have any dimensions") @@ -1304,8 +1304,8 @@ subroutine get_dimension_names(fileobj, names, broadcast) if (.not. fileobj%is_root) then if (ndims .gt. 0) then if (size(names) .ne. ndims) then - call error("'names' has to be the same size of the number of dimensions."& - &" Check your get_dimension_names call for file "//trim(fileobj%path)) + call error("'names' has to be the same size of the number of dimensions. & + &Check your get_dimension_names call for file "//trim(fileobj%path)) endif else call error("get_dimension_names: the file "//trim(fileobj%path)//" does not have any dimensions") @@ -1507,8 +1507,8 @@ subroutine get_variable_names(fileobj, names, broadcast) nvars = get_num_variables(fileobj, broadcast=.false.) if (nvars .gt. 0) then if (size(names) .ne. nvars) then - call error("'names' has to be the same size of the number of variables."& - &" Check your get_variable_names call for file "//trim(fileobj%path)) + call error("'names' has to be the same size of the number of variables. & + &Check your get_variable_names call for file "//trim(fileobj%path)) endif else call error("get_variable_names: the file "//trim(fileobj%path)//" does not have any variables") @@ -1528,8 +1528,8 @@ subroutine get_variable_names(fileobj, names, broadcast) if (.not. fileobj%is_root) then if (nvars .gt. 0) then if (size(names) .ne. nvars) then - call error("'names' has to be the same size of the number of variables."& - &" Check your get_variable_names call for file "//trim(fileobj%path)) + call error("'names' has to be the same size of the number of variables. & + &Check your get_variable_names call for file "//trim(fileobj%path)) endif else call error("get_variable_names: the file "//trim(fileobj%path)//" does not have any variables") @@ -1641,9 +1641,9 @@ subroutine get_variable_dimension_names(fileobj, variable_name, dim_names, & call check_netcdf_code(err, append_error_msg) if (ndims .gt. 0) then if (size(dim_names) .ne. ndims) then - call error("'names' has to be the same size of the number of dimensions for the variable."& - &" Check your get_variable_dimension_names call for file "//trim(fileobj%path)//& - &" and variable:"//trim(variable_name)) + call error("'names' has to be the same size of the number of dimensions for the variable. & + &Check your get_variable_dimension_names call for file "//trim(fileobj%path)// & + " and variable:"//trim(variable_name)) endif else call error("get_variable_dimension_names: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)& @@ -1664,9 +1664,9 @@ subroutine get_variable_dimension_names(fileobj, variable_name, dim_names, & if (.not. fileobj%is_root) then if (ndims .gt. 0) then if (size(dim_names) .ne. ndims) then - call error("'names' has to be the same size of the number of dimensions for the variable."& - &" Check your get_variable_dimension_names call for file "//trim(fileobj%path)//& - &" and variable:"//trim(variable_name)) + call error("'names' has to be the same size of the number of dimensions for the variable. & + & Check your get_variable_dimension_names call for file "//trim(fileobj%path)// & + " and variable:"//trim(variable_name)) endif else call error("get_variable_dimension_names: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)& @@ -1707,9 +1707,9 @@ subroutine get_variable_size(fileobj, variable_name, dim_sizes, broadcast) call check_netcdf_code(err, append_error_msg) if (ndims .gt. 0) then if (size(dim_sizes) .ne. ndims) then - call error("'dim_sizes' has to be the same size of the number of dimensions for the variable."& - &" Check your get_variable_size call for file "//trim(fileobj%path)//& - &" and variable:"//trim(variable_name)) + call error("'dim_sizes' has to be the same size of the number of dimensions for the variable. & + &Check your get_variable_size call for file "//trim(fileobj%path)// & + " and variable:"//trim(variable_name)) endif else call error("get_variable_size: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//& @@ -1729,9 +1729,9 @@ subroutine get_variable_size(fileobj, variable_name, dim_sizes, broadcast) if (.not. fileobj%is_root) then if (ndims .gt. 0) then if (size(dim_sizes) .ne. ndims) then - call error("'dim_sizes' has to be the same size of the number of dimensions for the variable."& - &" Check your get_variable_size call for file "//trim(fileobj%path)//& - &" and variable:"//trim(variable_name)) + call error("'dim_sizes' has to be the same size of the number of dimensions for the variable. & + &Check your get_variable_size call for file "//trim(fileobj%path)// & + " and variable:"//trim(variable_name)) endif else call error("get_variable_size: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//& @@ -2227,8 +2227,8 @@ function is_registered_to_restart(fileobj, variable_name) & integer :: i if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file. "& - //"Add is_restart=.true. to your open_file call") + call error("file "//trim(fileobj%path)//" is not a restart file. & + &Add is_restart=.true. to your open_file call") endif is_registered = .false. do i = 1, fileobj%num_restart_vars @@ -2320,8 +2320,8 @@ subroutine write_restart_bc(fileobj, unlim_dim_level) integer :: i !< No description if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file. "& - &"Add is_restart=.true. to your open_file call") + call error("file "//trim(fileobj%path)//" is not a restart file. & + &Add is_restart=.true. to your open_file call") endif !> Loop through the variables, root pe gathers the data from the other pes and writes out the checksum. diff --git a/horiz_interp/horiz_interp.F90 b/horiz_interp/horiz_interp.F90 index 07df2b7a69..9a910ccf11 100644 --- a/horiz_interp/horiz_interp.F90 +++ b/horiz_interp/horiz_interp.F90 @@ -54,6 +54,7 @@ module horiz_interp_mod use horiz_interp_conserve_mod, only: horiz_interp_conserve_new, horiz_interp_conserve_del use horiz_interp_bilinear_mod, only: horiz_interp_bilinear_init, horiz_interp_bilinear use horiz_interp_bilinear_mod, only: horiz_interp_bilinear_new, horiz_interp_bilinear_del +use horiz_interp_bilinear_mod, only: horiz_interp_read_weights_bilinear use horiz_interp_bicubic_mod, only: horiz_interp_bicubic_init, horiz_interp_bicubic use horiz_interp_bicubic_mod, only: horiz_interp_bicubic_new, horiz_interp_bicubic_del use horiz_interp_spherical_mod, only: horiz_interp_spherical_init, horiz_interp_spherical @@ -66,7 +67,7 @@ module horiz_interp_mod !---- interfaces ---- public horiz_interp_type, horiz_interp, horiz_interp_new, horiz_interp_del, & - horiz_interp_init, horiz_interp_end, assignment(=) + horiz_interp_init, horiz_interp_end, assignment(=), horiz_interp_read_weights !> Allocates space and initializes a derived-type variable !! that contains pre-computed interpolation indices and weights. @@ -137,6 +138,12 @@ module horiz_interp_mod module procedure horiz_interp_new_1d_dst_r8 end interface + !> Subroutines for reading in weight files and using that to fill in the horiz_interp type instead + !! calculating it + interface horiz_interp_read_weights + module procedure horiz_interp_read_weights_r4 + module procedure horiz_interp_read_weights_r8 + end interface horiz_interp_read_weights !> Subroutine for performing the horizontal interpolation between two grids. !! diff --git a/horiz_interp/horiz_interp_bilinear.F90 b/horiz_interp/horiz_interp_bilinear.F90 index 2fe80b9895..d8db732b22 100644 --- a/horiz_interp/horiz_interp_bilinear.F90 +++ b/horiz_interp/horiz_interp_bilinear.F90 @@ -35,13 +35,15 @@ module horiz_interp_bilinear_mod use horiz_interp_type_mod, only: horiz_interp_type, stats, BILINEAR use platform_mod, only: r4_kind, r8_kind use axis_utils2_mod, only: nearest_index + use fms2_io_mod, only: open_file, close_file, read_data, FmsNetcdfFile_t, get_dimension_size + use fms_string_utils_mod, only: string implicit none private public :: horiz_interp_bilinear_new, horiz_interp_bilinear, horiz_interp_bilinear_del - public :: horiz_interp_bilinear_init + public :: horiz_interp_bilinear_init, horiz_interp_read_weights_bilinear !> Creates a @ref horiz_interp_type for bilinear interpolation. !> @ingroup horiz_interp_bilinear_mod @@ -52,6 +54,14 @@ module horiz_interp_bilinear_mod module procedure horiz_interp_bilinear_new_2d_r8 end interface + !> Subroutines for reading in weight files and using that to fill in the horiz_interp type instead + !! calculating it + !> @ingroup horiz_interp_bilinear_mod + interface horiz_interp_read_weights_bilinear + module procedure horiz_interp_read_weights_bilinear_r4 + module procedure horiz_interp_read_weights_bilinear_r8 + end interface + interface horiz_interp_bilinear module procedure horiz_interp_bilinear_r4 module procedure horiz_interp_bilinear_r8 diff --git a/horiz_interp/include/horiz_interp.inc b/horiz_interp/include/horiz_interp.inc index 036b87a268..c3fe335b14 100644 --- a/horiz_interp/include/horiz_interp.inc +++ b/horiz_interp/include/horiz_interp.inc @@ -840,4 +840,52 @@ return end function IS_LAT_LON_ + + !> Subroutine for reading a weight file and use it to fill in the horiz interp type +!! for the bilinear interpolation method. + subroutine HORIZ_INTERP_READ_WEIGHTS_(Interp, weight_filename, lon_out, lat_out, lon_in, lat_in, & + weight_file_source, interp_method, isw, iew, jsw, jew, nglon, nglat) + type(horiz_interp_type), intent(inout) :: Interp !< Horiz interp time to fill + character(len=*), intent(in) :: weight_filename !< Name of the weight file + real(FMS_HI_KIND_), intent(in) :: lat_out(:,:) !< Output (model) latitude + real(FMS_HI_KIND_), intent(in) :: lon_out(:,:) !< Output (model) longitude + real(FMS_HI_KIND_), intent(in) :: lat_in(:) !< Input (data) latitude + real(FMS_HI_KIND_), intent(in) :: lon_in(:) !< Input (data) longitude + character(len=*), intent(in) :: weight_file_source !< Source of the weight file + character(len=*), intent(in) :: interp_method !< The interp method to use + integer, intent(in) :: isw, iew, jsw, jew !< Starting and ending indices of the compute domain + integer, intent(in) :: nglon !< Number of longitudes in the global domain + integer, intent(in) :: nglat !< Number of latitudes in the globl domain + + integer :: i, j !< For do loops + integer :: nlon_in !< Number of longitude in the data + integer :: nlat_in !< Number of latitude in the data grid + real(FMS_HI_KIND_), allocatable :: lon_src_1d(:) !< Center points of the longitude data grid + real(FMS_HI_KIND_), allocatable :: lat_src_1d(:) !< Center points of the lattiude data grid + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling + + select case (trim(interp_method)) + case ("bilinear") + !! This is to reproduce the behavior in horiz_interp_new + !! The subroutine assumes that the data grid (lon_in, lat_in) are + !! the edges and not the centers. + !! Data_override passes in the edges, which are calculated using the axis_edges subroutine + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + + call horiz_interp_read_weights_bilinear(Interp, weight_filename, lon_out, lat_out, & + lon_src_1d, lat_src_1d, weight_file_source, interp_method, & + isw, iew, jsw, jew, nglon, nglat) + deallocate(lon_src_1d,lat_src_1d) + case default + call mpp_error(FATAL, "Reading weight from file is not supported for the "//& + trim(interp_method)//" method. It is currently only supported for bilinear") + end select + end subroutine HORIZ_INTERP_READ_WEIGHTS_ !> @} diff --git a/horiz_interp/include/horiz_interp_bilinear.inc b/horiz_interp/include/horiz_interp_bilinear.inc index f178ebec1c..f998b823f7 100644 --- a/horiz_interp/include/horiz_interp_bilinear.inc +++ b/horiz_interp/include/horiz_interp_bilinear.inc @@ -1209,4 +1209,93 @@ return end subroutine + + !> Subroutine for reading a weight file and use it to fill in the horiz interp type + !! for the bilinear interpolation method. + subroutine HORIZ_INTERP_READ_WEIGHTS_BILINEAR_(Interp, weight_filename, lon_out, lat_out, lon_in, lat_in, & + weight_file_source, interp_method, isw, iew, jsw, jew, nglon, nglat) + type(horiz_interp_type), intent(inout) :: Interp !< Horiz interp time to fill + character(len=*), intent(in) :: weight_filename !< Name of the weight file + real(FMS_HI_KIND_), target, intent(in) :: lat_out(:,:) !< Output (model) latitude + real(FMS_HI_KIND_), target, intent(in) :: lon_out(:,:) !< Output (model) longitude + real(FMS_HI_KIND_), intent(in) :: lat_in(:) !< Input (data) latitude + real(FMS_HI_KIND_), intent(in) :: lon_in(:) !< Input (data) longitude + character(len=*), intent(in) :: weight_file_source !< Source of the weight file + character(len=*), intent(in) :: interp_method !< The interp method to use + integer, intent(in) :: isw, iew, jsw, jew !< Starting and ending indices of the compute domain + integer, intent(in) :: nglon !< Number of longitudes in the global domain + integer, intent(in) :: nglat !< Number of latitudes in the globl domain + + + real(FMS_HI_KIND_), allocatable :: var(:,:,:) !< Dummy variable to read the indices and weight into + type(FmsNetcdfFile_t) :: weight_fileobj !< FMS2io fileob for the weight file + integer :: nlon !< Number of longitudes in the model grid as read + !! from the weight file + integer :: nlat !< Number of latitude in the model grid as read + !! from the weight file + + if (.not. open_file(weight_fileobj, weight_filename, "read" )) & + call mpp_error(FATAL, "Error opening the weight file:"//& + &trim(weight_filename)) + + !< Check that weight file has the correct dimensions + select case (trim(weight_file_source)) + case ("fregrid") + call get_dimension_size(weight_fileobj, "nlon", nlon) + if (nlon .ne. nglon) & + call mpp_error(FATAL, "The nlon from the weight file is not the same as in the input grid."//& + &" From weight file:"//string(nlon)//" from input grid:"//string(size(lon_out,1))) + call get_dimension_size(weight_fileobj, "nlat", nlat) + if (nlat .ne. nglat) & + call mpp_error(FATAL, "The nlat from the weight file is not the same as in the input grid."//& + &" From weight file:"//string(nlat)//" from input grid:"//string(size(lon_out,2))) + case default + call mpp_error(FATAL, trim(weight_file_source)//& + &" is not a supported weight file source. fregrid is the only supported weight file source." ) + end select + + Interp%nlon_src = size(lon_in(:)) ; Interp%nlat_src = size(lat_in(:)) + Interp%nlon_dst = size(lon_out,1); Interp%nlat_dst = size(lon_out,2) + + allocate ( Interp % HI_KIND_TYPE_ % wti (Interp%nlon_dst,Interp%nlat_dst,2), & + Interp % HI_KIND_TYPE_ % wtj (Interp%nlon_dst,Interp%nlat_dst,2), & + Interp % i_lon (Interp%nlon_dst,Interp%nlat_dst,2), & + Interp % j_lat (Interp%nlon_dst,Interp%nlat_dst,2)) + + + !! Three is for lon, lat, tile + !! Currently, interpolation is only supported from lat,lon input data + allocate(var(Interp%nlon_dst,Interp%nlat_dst, 3)) + call read_data(weight_fileobj, "index", var, corner=(/isw, jsw, 1/), edge_lengths=(/iew-isw+1, jew-jsw+1, 3/)) + + !! Each point has a lon (i), and lat(j) index + !! From there the four corners are (i,j), (i,j+1) (i+1) (i+1,j+1) + Interp % i_lon (:,:,1) = var(:,:,1) + Interp % i_lon (:,:,2) = Interp % i_lon (:,:,1) + 1 + where (Interp % i_lon (:,:,2) > size(lon_in(:))) Interp % i_lon (:,:,2) = 1 + + Interp % j_lat (:,:,1) = var(:,:,2) + Interp % j_lat (:,:,2) = Interp % j_lat (:,:,1) + 1 + where (Interp % j_lat (:,:,2) > size(lat_in(:))) Interp % j_lat (:,:,2) = 1 + + deallocate(var) + + allocate(var(Interp%nlon_dst,Interp%nlat_dst, 4)) + call read_data(weight_fileobj, "weight", var, corner=(/isw, jsw, 1/), edge_lengths=(/iew-isw+1, jew-jsw+1, 4/)) + + !! The weights for the four corners + !! var(:,:,1) -> (i,j) + !! var(:,:,2) -> (i,j+1) + !! var(:,:,3) -> (i+1,j) + !! var(:,:,4) -> (i+1,j+1) + Interp % HI_KIND_TYPE_ % wti = var(:,:,1:2) + Interp % HI_KIND_TYPE_ % wtj = var(:,:,3:4) + deallocate(var) + + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp% interp_method = BILINEAR + Interp% I_am_initialized = .True. + call close_file(weight_fileobj) + end subroutine HORIZ_INTERP_READ_WEIGHTS_BILINEAR_ + !> @} diff --git a/horiz_interp/include/horiz_interp_bilinear_r4.fh b/horiz_interp/include/horiz_interp_bilinear_r4.fh index 8880914e43..36c462a057 100644 --- a/horiz_interp/include/horiz_interp_bilinear_r4.fh +++ b/horiz_interp/include/horiz_interp_bilinear_r4.fh @@ -45,5 +45,8 @@ #undef INTERSECT_ #define INTERSECT_ intersect_r4 +#undef HORIZ_INTERP_READ_WEIGHTS_BILINEAR_ +#define HORIZ_INTERP_READ_WEIGHTS_BILINEAR_ horiz_interp_read_weights_bilinear_r4 + #include "horiz_interp_bilinear.inc" !> @} diff --git a/horiz_interp/include/horiz_interp_bilinear_r8.fh b/horiz_interp/include/horiz_interp_bilinear_r8.fh index 37a2e6920b..05187557fc 100644 --- a/horiz_interp/include/horiz_interp_bilinear_r8.fh +++ b/horiz_interp/include/horiz_interp_bilinear_r8.fh @@ -45,5 +45,8 @@ #undef INTERSECT_ #define INTERSECT_ intersect_r8 +#undef HORIZ_INTERP_READ_WEIGHTS_BILINEAR_ +#define HORIZ_INTERP_READ_WEIGHTS_BILINEAR_ horiz_interp_read_weights_bilinear_r8 + #include "horiz_interp_bilinear.inc" !> @} diff --git a/horiz_interp/include/horiz_interp_r4.fh b/horiz_interp/include/horiz_interp_r4.fh index a3211ee6e5..89b3e60559 100644 --- a/horiz_interp/include/horiz_interp_r4.fh +++ b/horiz_interp/include/horiz_interp_r4.fh @@ -60,5 +60,8 @@ #undef IS_LAT_LON_ #define IS_LAT_LON_ is_lat_lon_r4 +#undef HORIZ_INTERP_READ_WEIGHTS_ +#define HORIZ_INTERP_READ_WEIGHTS_ horiz_interp_read_weights_r4 + #include "horiz_interp.inc" !> @} diff --git a/horiz_interp/include/horiz_interp_r8.fh b/horiz_interp/include/horiz_interp_r8.fh index 713be92065..312a31403a 100644 --- a/horiz_interp/include/horiz_interp_r8.fh +++ b/horiz_interp/include/horiz_interp_r8.fh @@ -60,5 +60,8 @@ #undef IS_LAT_LON_ #define IS_LAT_LON_ is_lat_lon_r8 +#undef HORIZ_INTERP_READ_WEIGHTS_ +#define HORIZ_INTERP_READ_WEIGHTS_ horiz_interp_read_weights_r8 + #include "horiz_interp.inc" !> @} diff --git a/include/fms_platform.h b/include/fms_platform.h index 30feb9f73b..9a473f49f8 100644 --- a/include/fms_platform.h +++ b/include/fms_platform.h @@ -88,5 +88,12 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & #define QUAD_KIND DOUBLE_KIND #endif +!Max string sizes for paths and files +#ifndef FMS_MAX_PATH_LEN +#define FMS_MAX_PATH_LEN 1024 +#endif +#ifndef FMS_MAX_FILE_LEN +#define FMS_MAX_FILE_LEN 255 +#endif #endif diff --git a/interpolator/include/interpolator.inc b/interpolator/include/interpolator.inc index 7f32260411..a60512fd6c 100644 --- a/interpolator/include/interpolator.inc +++ b/interpolator/include/interpolator.inc @@ -127,7 +127,7 @@ integer , intent(in), optional :: vert_interp(:) character(len=*), intent(out), optional :: clim_units(:) logical, intent(out), optional :: single_year_file -character(len=128) :: src_file +character(len=FMS_FILE_LEN) :: src_file !++lwh real(FMS_INTP_KIND_) :: dlat, dlon !--lwh diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index a00cf6b7c0..e645e89545 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -81,7 +81,7 @@ module interpolator_mod decrement_time use time_interp_mod, only : time_interp, YEAR use constants_mod, only : grav, PI, SECONDS_PER_DAY -use platform_mod, only : r4_kind, r8_kind, r16_kind +use platform_mod, only : r4_kind, r8_kind, r16_kind, FMS_PATH_LEN, FMS_FILE_LEN !-------------------------------------------------------------------- @@ -296,7 +296,7 @@ module interpolator_mod type(horiz_interp_type) :: interph !< No description type(time_type), allocatable :: time_slice(:) !< An array of the times within the climatology. type(FmsNetcdfFile_t) :: fileobj ! object that stores opened file information -character(len=64) :: file_name !< Climatology filename +character(len=FMS_PATH_LEN) :: file_name !< Climatology filename integer :: TIME_FLAG !< Linear or seaonal interpolation? integer :: level_type !< Pressure or Sigma level integer :: is,ie,js,je !< No description diff --git a/mosaic2/grid2.F90 b/mosaic2/grid2.F90 index e486777744..dbf6a59c5f 100644 --- a/mosaic2/grid2.F90 +++ b/mosaic2/grid2.F90 @@ -122,7 +122,6 @@ module grid2_mod integer, parameter :: & MAX_NAME = 256, & !< max length of the variable names - MAX_FILE = 1024, & !< max length of the file names VERSION_GEOLON_T = 0, & !< indicates gelon_t variable is present in grid_file VERSION_X_T = 1, & !< indicates x_t variable is present in grid_file VERSION_OCN_MOSAIC_FILE = 2, & !< indicates ocn_mosaic_file variable is present in grid_file @@ -200,7 +199,7 @@ subroutine open_mosaic_file(mymosaicfileobj, component) type(FmsNetcdfFile_t), intent(out) :: mymosaicfileobj !< File object returned character(len=3), intent(in) :: component !< Component (atm, lnd, etc.) - character(len=MAX_FILE) :: mosaicfilename + character(len=FMS_PATH_LEN) :: mosaicfilename if (.not. grid_spec_exists) then call mpp_error(FATAL, 'grid2_mod(open_mosaic_file): grid_spec does not exist') end if @@ -215,8 +214,8 @@ function read_file_name(thisfileobj, filevar, level) character(len=*), intent(in) :: filevar!< Variable containing file names integer, intent(in) :: level !< Level of tile file integer, dimension(2) :: file_list_size - character(len=MAX_FILE) :: read_file_name - character(len=MAX_FILE), dimension(:), allocatable :: file_names + character(len=FMS_PATH_LEN) :: read_file_name + character(len=FMS_PATH_LEN), dimension(:), allocatable :: file_names call get_variable_size(thisfileobj, filevar, file_list_size) allocate(file_names(file_list_size(2))) diff --git a/mosaic2/include/grid2.inc b/mosaic2/include/grid2.inc index 6717ba530a..42156420bd 100644 --- a/mosaic2/include/grid2.inc +++ b/mosaic2/include/grid2.inc @@ -88,7 +88,7 @@ subroutine GET_GRID_COMP_AREA_SG_(component,tile,area,domain) xgrid_name, & ! name of the variable holding xgrid names tile_name, & ! name of the tile mosaic_name ! name of the mosaic - character(len=MAX_FILE) :: & + character(len=FMS_PATH_LEN) :: & tilefile, & ! name of current tile file xgrid_file ! name of the current xgrid file character(len=4096) :: attvalue @@ -301,7 +301,7 @@ subroutine GET_GRID_CELL_VERTICES_1D_(component, tile, glonb, glatb) integer :: nlon, nlat integer :: start(4), nread(4) real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) - character(len=MAX_FILE) :: tilefile + character(len=FMS_PATH_LEN) :: tilefile type(FmsNetcdfFile_t) :: tilefileobj call get_grid_size_for_one_tile(component, tile, nlon, nlat) @@ -392,7 +392,7 @@ subroutine GET_GRID_CELL_VERTICES_2D_(component, tile, lonb, latb, domain) integer :: i0,j0 ! offsets for coordinates integer :: isg, jsg integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile + character(len=FMS_PATH_LEN) :: tilefile type(FmsNetcdfFile_t) :: tilefileobj call get_grid_size_for_one_tile(component, tile, nlon, nlat) @@ -581,7 +581,7 @@ subroutine GET_GRID_CELL_CENTERS_1D_(component, tile, glon, glat) integer :: nlon, nlat integer :: start(4), nread(4) real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:) - character(len=MAX_FILE) :: tilefile + character(len=FMS_PATH_LEN) :: tilefile type(FmsNetcdfFile_t) :: tilefileobj call get_grid_size_for_one_tile(component, tile, nlon, nlat) @@ -657,7 +657,7 @@ subroutine GET_GRID_CELL_CENTERS_2D_(component, tile, lon, lat, domain) integer :: i0,j0 ! offsets for coordinates integer :: isg, jsg integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile + character(len=FMS_PATH_LEN) :: tilefile type(FmsNetcdfFile_t) :: tilefileobj call get_grid_size_for_one_tile(component, tile, nlon, nlat) diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index c76b30adb7..da259e5d8d 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -38,7 +38,7 @@ module mosaic2_mod use constants_mod, only : PI, RADIUS use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, get_dimension_size use fms2_io_mod, only : read_data, variable_exists -use platform_mod, only : r4_kind, r8_kind +use platform_mod, only : r4_kind, r8_kind, FMS_PATH_LEN implicit none private @@ -48,7 +48,6 @@ module mosaic2_mod integer, parameter :: & MAX_NAME = 256, & !> max length of the variable names - MAX_FILE = 1024, & !> max length of the file names X_REFINE = 2, & !> supergrid size/model grid size in x-direction Y_REFINE = 2 !> supergrid size/model grid size in y-direction @@ -174,7 +173,7 @@ subroutine get_mosaic_grid_sizes( fileobj, nx, ny) type(FmsNetcdfFile_t), intent(in) :: fileobj integer, dimension(:), intent(inout) :: nx, ny - character(len=MAX_FILE) :: gridfile + character(len=FMS_PATH_LEN) :: gridfile integer :: ntiles, n type(FmsNetcdfFile_t) :: gridobj diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc index a86fcba626..d49a9ecbac 100644 --- a/mpp/include/mpp_util.inc +++ b/mpp/include/mpp_util.inc @@ -870,7 +870,7 @@ end function rarray_to_char integer :: SD_UNIT, total_calls integer :: j,k,ct, msg_cnt character(len=2) :: u - character(len=20) :: filename + character(len=FMS_FILE_LEN) :: filename character(len=20),dimension(MAX_BINS),save :: bin data bin( 1) /' 0 - 8 B: '/ @@ -1228,7 +1228,7 @@ end function rarray_to_char integer, dimension(2) :: lines_and_length logical :: file_exist character(len=len(peset(current_peset_num)%name)) :: pelist_name - character(len=128) :: filename + character(len=FMS_PATH_LEN) :: filename ! check the status of input_nml_file if ( allocated(input_nml_file) ) then @@ -1389,8 +1389,8 @@ end function rarray_to_char call mpp_error(FATAL, 'get_ascii_file_num_lines: Error reading line '//trim(text)// & ' in file '//trim(FILENAME)//'.') end if - if ( len_trim(str_tmp) == LENGTH ) then - write(UNIT=text, FMT='(I5)') length + if ( len_trim(str_tmp) == LENGTH) then + write(UNIT=text, FMT='(I5)') LENGTH call mpp_error(FATAL, 'get_ascii_file_num_lines: Length of output string ('//trim(text)//& & ' is too small. Increase the LENGTH value.') end if diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index 9c9ae0a793..3a3c7f0051 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -59,6 +59,12 @@ module yaml_parser_mod module procedure get_value_from_key_1d end interface get_value_from_key +!! Error codes from open_and_parse_file_wrap +integer, parameter :: MISSING_FILE = -1 !< Error code if the yaml file is missing +integer, parameter :: PARSER_INIT_ERROR = -2 !< Error code if unable to create a parser object +integer, parameter :: INVALID_YAML = -3 !< Error code if unable to parse a yaml file +integer, parameter :: SUCCESSFUL = 1 !< "Error" code if the parsing was successful + !> @brief c functions binding !> @ingroup yaml_parser_mod interface @@ -66,11 +72,11 @@ module yaml_parser_mod !> @brief Private c function that opens and parses a yaml file (see yaml_parser_binding.c) !! @return Flag indicating if the read was successful function open_and_parse_file_wrap(filename, file_id) bind(c) & - result(success) + result(error_code) 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) :: success !< Flag indicating if the read was successful + logical(kind=c_int) :: error_code !< Flag indicating the error message (1 if 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) @@ -240,7 +246,7 @@ function open_and_parse_file(filename) & result(file_id) character(len=*), intent(in) :: filename !< Filename of the yaml file - logical :: success !< Flag indicating if the read was successful + integer :: error_code !< Flag indicating any errors in the parsing or 1 if sucessful logical :: yaml_exists !< Flag indicating whether the yaml exists integer :: file_id @@ -251,11 +257,28 @@ function open_and_parse_file(filename) & call mpp_error(NOTE, "The yaml file:"//trim(filename)//" does not exist, hopefully this is your intent!") return end if - success = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) - if (.not. success) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") + error_code = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) + call check_error_code(error_code, filename) end function open_and_parse_file +!> @brief Checks the error code from a open_and_parse_file_wrap function call +subroutine check_error_code(error_code, filename) + integer, intent(in) :: error_code + character(len=*), intent(in) :: filename + + select case (error_code) + case (SUCCESSFUL) + return + case (MISSING_FILE) + call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)) + case (PARSER_INIT_ERROR) + call mpp_error(FATAL, "Error initializing the parser for the file:"//trim(filename)) + case (INVALID_YAML) + call mpp_error(FATAL, "Error parsing the file:"//trim(filename)//". Check that your yaml file is valid") + end select +end subroutine check_error_code + !> @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 diff --git a/parser/yaml_parser_binding.c b/parser/yaml_parser_binding.c index 42795fbba8..778b6267dc 100644 --- a/parser/yaml_parser_binding.c +++ b/parser/yaml_parser_binding.c @@ -300,7 +300,7 @@ bool is_valid_file_id(int *file_id) /* @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) +int open_and_parse_file_wrap(char *filename, int *file_id) { yaml_parser_t parser; yaml_token_t token; @@ -330,9 +330,9 @@ bool open_and_parse_file_wrap(char *filename, int *file_id) /* printf("Opening file: %s.\nThere are %i files opened.\n", filename, j); */ file = fopen(filename, "r"); - if (file == NULL) return false; + if (file == NULL) return -1; - if(!yaml_parser_initialize(&parser)) return false; + if(!yaml_parser_initialize(&parser)) return -2; my_files.files[j].keys = (key_value_pairs*)calloc(1, sizeof(key_value_pairs)); @@ -341,7 +341,9 @@ bool open_and_parse_file_wrap(char *filename, int *file_id) /* Set input file */ yaml_parser_set_input_file(&parser, file); do { - yaml_parser_scan(&parser, &token); + if (!yaml_parser_scan(&parser, &token)) { + return -3; + } switch(token.type) { case YAML_KEY_TOKEN: @@ -420,7 +422,7 @@ bool open_and_parse_file_wrap(char *filename, int *file_id) /* printf("closing file: %s\n", filename); */ fclose(file); - return true; + return 1; } #endif diff --git a/platform/platform.F90 b/platform/platform.F90 index ed5d9a2568..9845d3f330 100644 --- a/platform/platform.F90 +++ b/platform/platform.F90 @@ -32,6 +32,8 @@ module platform_mod l8_kind=LONG_KIND, l4_kind=INT_KIND, & i8_kind=LONG_KIND, i4_kind=INT_KIND, i2_kind=SHORT_KIND, & ptr_kind=POINTER_KIND + integer, parameter :: FMS_PATH_LEN = FMS_MAX_PATH_LEN + integer, parameter :: FMS_FILE_LEN = FMS_MAX_FILE_LEN !could additionally define things like OS, compiler...: useful? end module platform_mod !> @} diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index 69f09540fa..087bd91ea3 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -73,11 +73,11 @@ TESTS_ENVIRONMENT= test_input_path="@TEST_INPUT_PATH@" \ # Run the test program. TESTS = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ - test_data_override2_scalar.sh + test_data_override2_scalar.sh test_data_override_weights.sh # Include these files with the distribution. EXTRA_DIST = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ - test_data_override2_scalar.sh + test_data_override2_scalar.sh test_data_override_weights.sh # Clean up CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml INPUT/* *.dpi *.spi *.dyn *.spl *-files/* diff --git a/test_fms/data_override/test_data_override2_mono.sh b/test_fms/data_override/test_data_override2_mono.sh index cf47a152f9..be1cce4103 100755 --- a/test_fms/data_override/test_data_override2_mono.sh +++ b/test_fms/data_override/test_data_override2_mono.sh @@ -59,17 +59,19 @@ _EOF cat <<_EOF > data_table.yaml data_table: -- gridname: OCN - fieldname_code: runoff_increasing - fieldname_file: runoff - file_name: ./INPUT/bilinear_increasing.nc - interpol_method: bilinear +- grid_name: OCN + fieldname_in_model: runoff_increasing + override_file: + - fieldname_in_file: runoff + file_name: ./INPUT/bilinear_increasing.nc + interp_method: bilinear factor: 1.0 -- gridname: OCN - fieldname_code: runoff_decreasing - fieldname_file: runoff - file_name: ./INPUT/bilinear_decreasing.nc - interpol_method: bilinear +- grid_name: OCN + fieldname_in_model: runoff_decreasing + override_file: + - fieldname_in_file: runoff + file_name: ./INPUT/bilinear_decreasing.nc + interp_method: bilinear factor: 1.0 _EOF diff --git a/test_fms/data_override/test_data_override2_ongrid.sh b/test_fms/data_override/test_data_override2_ongrid.sh index 2e1d7a1b03..e9f36712ce 100755 --- a/test_fms/data_override/test_data_override2_ongrid.sh +++ b/test_fms/data_override/test_data_override2_ongrid.sh @@ -52,12 +52,13 @@ use_data_table_yaml=.True. _EOF 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 + - grid_name: OCN + fieldname_in_model: runoff + override_file: + - fieldname_in_file: runoff + file_name: INPUT/runoff.daitren.clim.1440x1080.v20180328.nc + interp_method: none + factor: 1.0 _EOF fi @@ -83,4 +84,4 @@ test_expect_success "data_override get_grid_v1 (${KIND})" ' done rm -rf INPUT *.nc # remove any leftover files to reduce size -test_done \ No newline at end of file +test_done diff --git a/test_fms/data_override/test_data_override2_scalar.sh b/test_fms/data_override/test_data_override2_scalar.sh index faf9aca08f..ac19b2b0a6 100755 --- a/test_fms/data_override/test_data_override2_scalar.sh +++ b/test_fms/data_override/test_data_override2_scalar.sh @@ -48,11 +48,12 @@ use_data_table_yaml=.True. _EOF cat <<_EOF > data_table.yaml data_table: - - gridname : OCN - fieldname_code : co2 - fieldname_file : co2 - file_name : INPUT/scalar.nc - interpol_method : none + - grid_name: OCN + fieldname_in_model: co2 + override_file: + - fieldname_in_file: co2 + file_name: INPUT/scalar.nc + interp_method: none factor : 1.0 _EOF fi @@ -68,4 +69,4 @@ test_expect_success "data_override scalar field (${KIND})" ' done rm -rf INPUT *.nc # remove any leftover files to reduce size -test_done \ No newline at end of file +test_done diff --git a/test_fms/data_override/test_data_override_ongrid.F90 b/test_fms/data_override/test_data_override_ongrid.F90 index 4345bb9f86..a05eb9d6c8 100644 --- a/test_fms/data_override/test_data_override_ongrid.F90 +++ b/test_fms/data_override/test_data_override_ongrid.F90 @@ -39,8 +39,8 @@ program test_data_override_ongrid integer, parameter :: lkind = DO_TEST_KIND_ integer, dimension(2) :: layout = (/2,3/) !< Domain layout -integer :: nlon !< Number of points in x axis -integer :: nlat !< Number of points in y axis +integer :: nlon = 360 !< Number of points in x axis +integer :: nlat = 180 !< Number of points in y axis type(domain2d) :: Domain !< Domain with mask table integer :: is !< Starting x index integer :: ie !< Ending x index @@ -51,9 +51,10 @@ program test_data_override_ongrid integer, parameter :: ongrid = 1 integer, parameter :: bilinear = 2 integer, parameter :: scalar = 3 +integer, parameter :: weight_file = 4 integer :: test_case = ongrid -namelist / test_data_override_ongrid_nml / nhalox, nhaloy, test_case +namelist / test_data_override_ongrid_nml / nhalox, nhaloy, test_case, nlon, nlat, layout call mpp_init call fms2_io_init @@ -61,8 +62,6 @@ program test_data_override_ongrid read (input_nml_file, test_data_override_ongrid_nml, iostat=io_status) if (io_status > 0) call mpp_error(FATAL,'=>test_data_override_ongrid: Error reading input.nml') - - !< Wait for the root PE to catch up call mpp_sync @@ -70,9 +69,6 @@ program test_data_override_ongrid call set_calendar_type(NOLEAP) -nlon = 360 -nlat = 180 - !< Create a domain nlonXnlat with mask call mpp_domains_set_stack_size(17280000) call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, xhalo=nhalox, yhalo=nhaloy, name='test_data_override_emc') @@ -86,6 +82,8 @@ program test_data_override_ongrid call generate_bilinear_input_file () case (scalar) call generate_scalar_input_file () +case (weight_file) + call generate_weight_input_file () end select call mpp_sync() @@ -101,6 +99,8 @@ program test_data_override_ongrid call bilinear_test() case (scalar) call scalar_test() +case (weight_file) + call weight_file_test() end select call mpp_exit @@ -443,6 +443,99 @@ subroutine bilinear_test() deallocate(runoff_decreasing, runoff_increasing) end subroutine bilinear_test +subroutine generate_weight_input_file() + call create_grid_spec_file () + call create_ocean_mosaic_file() + call create_ocean_hgrid_file() + call create_bilinear_data_file(.true.) + call create_weight_file() +end subroutine + +subroutine create_weight_file() + type(FmsNetcdfFile_t) :: fileobj + real(kind=r8_kind), allocatable :: vdata(:,:,:) + character(len=5) :: dim_names(3) + + dim_names(1) = "nlon" + dim_names(2) = "nlat" + if (open_file(fileobj, "INPUT/remap_file.nc", "overwrite")) then + call register_axis(fileobj, "nlon", nlon) + call register_axis(fileobj, "nlat", nlat) + call register_axis(fileobj, "three", 3) + call register_axis(fileobj, "four", 4) + + dim_names(3) = "three" + call register_field(fileobj, "index", "int", dim_names) + + dim_names(3) = "four" + call register_field(fileobj, "weight", "double", dim_names) + + allocate(vdata(nlon,nlat,3)) + vdata(1,:,1) = 1 + vdata(2,:,1) = 2 + vdata(3,:,1) = 3 + vdata(4,:,1) = 4 + vdata(5,:,1) = 5 + vdata(:,1:2,2) = 1 + vdata(:,3,2) = 2 + vdata(:,4,2) = 3 + vdata(:,5,2) = 4 + vdata(:,6,2) = 5 + vdata(:,:,3) = 1 + call write_data(fileobj, "index", vdata) + deallocate(vdata) + + allocate(vdata(nlon,nlat,4)) + vdata = 0.5_r8_kind + vdata(:,1,3) = 1_r8_kind + vdata(:,6,3) = 1_r8_kind + vdata(:,1,4) = 0_r8_kind + vdata(:,6,4) = 0_r8_kind + + call write_data(fileobj, "weight", vdata) + deallocate(vdata) + + call close_file(fileobj) + endif +end subroutine create_weight_file + +subroutine weight_file_test() + type(time_type) :: Time !< Time + real(lkind), allocatable, dimension(:,:) :: runoff !< Data from normal override + real(lkind), allocatable, dimension(:,:) :: runoff_weight !< Data from weight file override + real(lkind) :: threshold !< Threshold for the difference in answers + + integer :: i, j, k + logical :: success + + allocate(runoff(is:ie,js:je)) + allocate(runoff_weight(is:ie,js:je)) + + runoff = 999_lkind + runoff_weight = 999_lkind + Time = set_date(1,1,4,0,0,0) + call data_override('OCN','runoff_obs',runoff, Time, override=success) + if (.not. success) call mpp_error(FATAL, "Data override failed") + call data_override('OCN','runoff_obs_weights',runoff_weight, Time, override=success) + if (.not. success) call mpp_error(FATAL, "Data override failed") + + threshold = 1e-09 + if (lkind .eq. 4) then + threshold = 1e-03 + endif + + do i = is, ie + do j = js, je + if (abs(runoff(i,j) - runoff_weight(i,j)) .gt. threshold) then + call mpp_error(FATAL, "The data is not the same: "// & + string(i)//","//string(j)//":"// & + string(runoff(i,j))//" vs "//string(runoff_weight(i,j))) + endif + enddo + enddo + deallocate(runoff, runoff_weight) +end subroutine weight_file_test + !> @brief Generates the input for the bilinear data_override test_case subroutine generate_scalar_input_file() if (mpp_pe() .eq. mpp_root_pe()) then diff --git a/test_fms/data_override/test_data_override_weights.sh b/test_fms/data_override/test_data_override_weights.sh new file mode 100755 index 0000000000..a3bc8902e4 --- /dev/null +++ b/test_fms/data_override/test_data_override_weights.sh @@ -0,0 +1,76 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** +# +# Copyright (c) 2019-2021 Ed Hartnett, Uriel Ramirez, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +output_dir +[ ! -d "INPUT" ] && mkdir -p "INPUT" + +cat <<_EOF > data_table.yaml +data_table: +- grid_name: OCN + fieldname_in_model: runoff_obs + override_file: + - fieldname_in_file: runoff + file_name: ./INPUT/bilinear_increasing.nc + interp_method: bilinear + factor: 1.0 +- grid_name: OCN + fieldname_in_model: runoff_obs_weights + override_file: + - fieldname_in_file: runoff + file_name: ./INPUT/bilinear_increasing.nc + interp_method: bilinear + external_weights: + - file_name: ./INPUT/remap_file.nc + source: fregrid + factor: 1.0 +_EOF + +cat <<_EOF > input.nml +&data_override_nml + use_data_table_yaml = .True. +/ + +&test_data_override_ongrid_nml + test_case = 4 + nlon = 5 + nlat = 6 + layout = 1, 2 +/ +_EOF + +#The test only runs with yaml +if [ -z $parser_skip ]; then + for KIND in r4 r8 + do + rm -rf INPUT/. + test_expect_success "test_data_override with and without weight files -yaml (${KIND})" ' + mpirun -n 2 ../test_data_override_ongrid_${KIND} + ' + done +fi + +rm -rf INPUT +test_done diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 629934b0b4..7b280c8855 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -516,6 +516,84 @@ if [ -z "${skipflag}" ]; then title: test_diag_manager base_date: 2 1 1 0 0 0 diag_files: +- file_name: wild_card_name%4yr%2mo%2dy%2hr + filename_time: end + freq: 6 hours + time_units: hours + unlimdim: time + new_file_freq: 6 hours + start_time: 2 1 1 0 0 0 + file_duration: 12 hours + module: test_diag_manager_mod + reduction: average + kind: r4 + varlist: + - var_name: sst + output_name: sst + global_meta: + - is_a_file: true +- file_name: normal + freq: 24 days + time_units: hours + unlimdim: records +# Here the module, kind and reduction are being overwritten with whats on the variable + module: potato_mod + kind: r8 + reduction: min + varlist: + - module: test_diag_manager_mod + var_name: sst + output_name: sst + reduction: average + kind: r4 + write_var: true + attributes: + - do_sst: .true. + sub_region: + - grid_type: latlon + corner1: -80, 0 + corner2: -80, 75 + corner3: -60, 0 + corner4: -60, 75 +- file_name: normal2 + freq: -1 + time_units: hours + unlimdim: records + write_file: true + module: test_diag_manager_mod + reduction: none + kind: r4 + varlist: + - var_name: sstt + output_name: sstt + long_name: S S T + - var_name: sstt2 + output_name: sstt2 + long_name: S S T + write_var: false + sub_region: + - grid_type: index + tile: 1 + corner1: 10, 15 + corner2: 20, 15 + corner3: 10, 25 + corner4: 20, 25 +- file_name: normal3 + freq: -1 + time_units: hours + unlimdim: records + write_file: false +_EOF + +my_test_count=`expr $my_test_count + 1` + test_expect_success "diag_yaml test with the simple diag table.yaml (test $my_test_count)" ' + mpirun -n 1 ../test_diag_yaml + ' + + cat <<_EOF > diag_table.yaml +title: test_diag_manager +base_date: 2 1 1 0 0 0 +diag_files: - file_name: wild_card_name%4yr%2mo%2dy%2hr filename_time: end freq: 6 hours diff --git a/test_fms/field_manager/test_field_manager2.sh b/test_fms/field_manager/test_field_manager2.sh index d3a165b164..2485701598 100755 --- a/test_fms/field_manager/test_field_manager2.sh +++ b/test_fms/field_manager/test_field_manager2.sh @@ -66,16 +66,16 @@ field_table: - variable: radon longname: radon-222 units: VMR*1E21 - profile_type: fixed - subparams: - - surface_value: 0.0E+00 + profile_type: + - value: fixed + surface_value: 0.0E+00 convection: all - model_type: ocean_mod varlist: - variable: biotic1 - diff_horiz: linear - subparams: - - slope: ok + diff_horiz: + - value: linear + slope: ok longname: biotic one - variable: age_ctl - model_type: land_mod diff --git a/test_fms/mpp/test_stdlog.F90 b/test_fms/mpp/test_stdlog.F90 index f8a9bc6d4e..61ee8d81c8 100644 --- a/test_fms/mpp/test_stdlog.F90 +++ b/test_fms/mpp/test_stdlog.F90 @@ -83,6 +83,8 @@ subroutine check_write() do i=1, 7 read(u_num_warn, '(A)') line if (trim(line) == '') cycle + !! if we're testing with the old io enabled, we'll have some additional output we can skip + if (trim(line) == 'NOTE from PE 0: MPP_IO_SET_STACK_SIZE: stack size set to 131072.') cycle if(trim(line) .ne. trim(ref_line(ref_num))) call mpp_error(FATAL, "warnfile output does not match reference data"& //"reference line:"//ref_line(ref_num) & //"output line:"//line) @@ -91,4 +93,5 @@ subroutine check_write() close(u_num_warn) end subroutine check_write -end program test_stdlog \ No newline at end of file +end program test_stdlog + diff --git a/test_fms/parser/parser_demo.F90 b/test_fms/parser/parser_demo.F90 index 5b4ccfd88e..208e41e807 100644 --- a/test_fms/parser/parser_demo.F90 +++ b/test_fms/parser/parser_demo.F90 @@ -38,7 +38,6 @@ program parser_demo 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 *, "" @@ -113,6 +112,7 @@ program parser_demo print *, "" enddo deallocate(file_ids) +call fms_end #endif end program parser_demo diff --git a/test_fms/parser/parser_demo2.F90 b/test_fms/parser/parser_demo2.F90 index c230559a4e..674ab85fbb 100644 --- a/test_fms/parser/parser_demo2.F90 +++ b/test_fms/parser/parser_demo2.F90 @@ -39,7 +39,6 @@ program parser_demo 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 *, "" @@ -102,6 +101,7 @@ program parser_demo print *, "" enddo deallocate(file_ids) +call fms_end #endif diff --git a/test_fms/parser/test_yaml_parser.sh b/test_fms/parser/test_yaml_parser.sh index 80c386e687..e5405baaf3 100755 --- a/test_fms/parser/test_yaml_parser.sh +++ b/test_fms/parser/test_yaml_parser.sh @@ -26,7 +26,7 @@ . ../test-lib.sh if [ ! -z $parser_skip ]; then - SKIP_TESTS='test_yaml_parser.[1-23]' + SKIP_TESTS='test_yaml_parser.[1-25]' fi touch input.nml @@ -294,4 +294,39 @@ _EOF test_expect_success "Generic blocks names" ' mpirun -n 1 ./generic_blocks ' + +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 + +test_expect_failure "Use an invalid yaml" ' + mpirun -n 1 ./parser_demo +' test_done diff --git a/test_fms/tracer_manager/test_tracer_manager2.sh b/test_fms/tracer_manager/test_tracer_manager2.sh index b35122fa3d..0c85ac76a5 100755 --- a/test_fms/tracer_manager/test_tracer_manager2.sh +++ b/test_fms/tracer_manager/test_tracer_manager2.sh @@ -75,25 +75,25 @@ field_table: - variable: radon longname: radon-222 units: VMR*1E21 - profile_type: fixed - subparams: - - surface_value: 0.0e+00 + profile_type: + - value: fixed + surface_value: 0.0e+00 convection: all - model_type: atmos_mod varlist: - variable: immadeup longname: im_made_up_for_testing units: hbar - profile_type: profile - subparams: - - surface_value: 1.02e-12 + profile_type: + - value: profile + surface_value: 1.02e-12 top_value: 1.0e-15 - model_type: ocean_mod varlist: - variable: biotic1 - diff_horiz: linear - subparams: - - slope: ok + diff_horiz: + - value: linear + slope: ok longname: biotic one - variable: age_ctl - model_type: ocean_mod @@ -101,9 +101,9 @@ field_table: - variable: immadeup2 longname: im_made_up2_for_testing units: hbar - profile_type: profile - subparams: - - surface_value: 1.0e-12 + profile_type: + - value: profile + surface_value: 1.0e-12 bottom_value: 1.0e-9 - model_type: land_mod varlist: diff --git a/time_interp/include/time_interp_external2.inc b/time_interp/include/time_interp_external2.inc index 863941df1d..d02f626504 100644 --- a/time_interp/include/time_interp_external2.inc +++ b/time_interp/include/time_interp_external2.inc @@ -69,7 +69,8 @@ integer :: nx, ny, nz, interp_method, t1, t2 integer :: i1, i2, isc, iec, jsc, jec, mod_time integer :: yy, mm, dd, hh, min, ss - character(len=256) :: err_msg, filename + character(len=256) :: err_msg + character(len=FMS_PATH_LEN) :: filename integer :: isw, iew, jsw, jew, nxw, nyw ! these are boundaries of the updated portion of the "data" argument @@ -236,7 +237,8 @@ integer :: t1, t2 integer :: i1, i2, mod_time integer :: yy, mm, dd, hh, min, ss - character(len=256) :: err_msg, filename + character(len=256) :: err_msg + character(len=FMS_PATH_LEN) :: filename real(FMS_TI_KIND_) :: w1,w2 logical :: verb diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index 02fad81f4b..0e5386ab3f 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -55,7 +55,7 @@ module time_interp_external2_mod use time_interp_mod, only : time_interp, time_interp_init use axis_utils2_mod, only : get_axis_cart, get_axis_modulo, get_axis_modulo_times use fms_mod, only : lowercase, check_nml_error - use platform_mod, only: r8_kind + use platform_mod, only: r8_kind, FMS_PATH_LEN, FMS_FILE_LEN use horiz_interp_mod, only : horiz_interp, horiz_interp_type use fms2_io_mod, only : Valid_t, FmsNetcdfDomainFile_t, open_file, get_unlimited_dimension_name, & variable_att_exists, FmsNetcdfFile_t, & @@ -126,7 +126,7 @@ module time_interp_external2_mod !> Holds filename and file object !> @ingroup time_interp_external2_mod type, private :: filetype - character(len=128) :: filename = '' + character(len=FMS_FILE_LEN) :: filename = '' type(FmsNetcdfFile_t), pointer :: fileobj => NULL() end type filetype diff --git a/topography/topography.F90 b/topography/topography.F90 index 3ff1288fc9..c35a79cbc3 100644 --- a/topography/topography.F90 +++ b/topography/topography.F90 @@ -51,7 +51,7 @@ module topography_mod use constants_mod, only: PI use mpp_mod, only: input_nml_file -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN implicit none private @@ -217,8 +217,8 @@ module topography_mod !> @addtogroup topography_mod !> @{ -character(len=128) :: topog_file = 'DATA/navy_topography.data', & - water_file = 'DATA/navy_pctwater.data' +character(len=FMS_PATH_LEN) :: topog_file = 'DATA/navy_topography.data', & + water_file = 'DATA/navy_pctwater.data' namelist /topography_nml/ topog_file, water_file integer, parameter :: TOPOG_INDEX = 1