From 89b76c8ede1d0000c0210242d3c633bcd9525a28 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 9 Aug 2023 09:48:07 -0400 Subject: [PATCH 01/23] Mixed precision data_override `data_override_mod` has been split into separate implementation and wrapper modules. Mixed precision support has been added. --- data_override/Makefile.am | 21 +- data_override/data_override.F90 | 1279 ++--------------- data_override/data_override_impl.F90 | 2 + data_override/get_grid_version.F90 | 242 +--- ...ta_override.inc => data_override_impl.inc} | 602 ++++---- .../include/data_override_impl_r4.fh | 50 + .../include/data_override_impl_r8.fh | 50 + data_override/include/get_grid_version.inc | 156 +- data_override/include/get_grid_version_r4.fh | 14 + data_override/include/get_grid_version_r8.fh | 14 + test_fms/data_override/Makefile.am | 28 +- test_fms/data_override/test_data_override.F90 | 24 +- test_fms/data_override/test_data_override2.sh | 53 +- .../test_data_override_ongrid.F90 | 38 +- test_fms/data_override/test_get_grid_v1.F90 | 27 +- 15 files changed, 704 insertions(+), 1896 deletions(-) create mode 100644 data_override/data_override_impl.F90 rename data_override/include/{data_override.inc => data_override_impl.inc} (76%) create mode 100644 data_override/include/data_override_impl_r4.fh create mode 100644 data_override/include/data_override_impl_r8.fh create mode 100644 data_override/include/get_grid_version_r4.fh create mode 100644 data_override/include/get_grid_version_r8.fh diff --git a/data_override/Makefile.am b/data_override/Makefile.am index 2cffbe3493..e6dfd7fe9d 100644 --- a/data_override/Makefile.am +++ b/data_override/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/data_override/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. @@ -31,15 +31,28 @@ noinst_LTLIBRARIES = libdata_override.la # The convenience library depends on its source. libdata_override_la_SOURCES = \ - data_override.F90 \ - get_grid_version.F90 + get_grid_version.F90 \ + include/get_grid_version_r4.fh \ + include/get_grid_version_r8.fh \ + include/get_grid_version.inc \ + data_override_impl.F90 \ + include/data_override_impl_r4.fh \ + include/data_override_impl_r8.fh \ + include/data_override_impl.inc \ + data_override.F90 # Some mods are dependent on other mods in this dir. -data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) +data_override_r4.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) +data_override_r8.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) +data_override_mod.$(FC_MODEXT): \ + data_override_r4.$(FC_MODEXT) \ + data_override_r8.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ data_override_mod.$(FC_MODEXT) \ + data_override_r4.$(FC_MODEXT) \ + data_override_r8.$(FC_MODEXT) \ get_grid_version_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index e95d5943d9..fe4e611c05 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.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 data_override_mod data_override_mod !> @ingroup data_override !! @brief Routines to get data in a file whose path is described in a user-provided data_table @@ -37,68 +38,16 @@ !! data_override will take place, field values outside the region will not be affected. module data_override_mod -use yaml_parser_mod -use constants_mod, only: PI -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(=) -use time_interp_external2_mod, only:time_interp_external_init, & - time_interp_external, & - init_external_field, & - get_external_field_size, & - set_override_region, & - reset_src_data_region, & - NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & - get_external_fileobj -use fms_mod, only: write_version_number, lowercase, check_nml_error -use axis_utils2_mod, only : nearest_index, axis_edges -use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.) -use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain -use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG -use time_manager_mod, only: time_type -use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & - read_data, fms2_io_init, variable_exists, & - get_mosaic_tile_file -use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 + use data_override_r4 + use data_override_r8 + use platform_mod, only: r4_kind, r8_kind + use mpp_mod, only: mpp_error, FATAL + use mpp_domains_mod, only : domain2d, domainUG + use time_manager_mod, only: time_type implicit none private -! Include variable "version" to be written to log file. -#include - -!> Private type for holding field and grid information from a data table -!> @ingroup data_override_mod -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=128) :: interpol_method !< interpolation method (default "bilinear") - real :: factor !< For unit conversion, default=1, see OVERVIEW above - real :: lon_start, lon_end, lat_start, lat_end - integer :: region_type -end type data_type - -!> Private type for holding various data fields for performing data overrides -!> @ingroup data_override_mod -type override_type - character(len=3) :: gridname - character(len=128) :: fieldname - integer :: t_index !< index for time interp - type(horiz_interp_type), allocatable :: horz_interp(:) !< index for horizontal spatial interp - integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename - integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain - integer :: numthreads - real, allocatable :: lon_in(:) - real, allocatable :: lat_in(:) - logical, allocatable :: need_compute(:) - integer :: numwindows - integer :: window_size(2) - integer :: is_src, ie_src, js_src, je_src -end type override_type - !> Interface for inserting and interpolating data into a file !! for a model's grid and time. Data path must be described in !! a user-provided data_table, see @ref data_override_mod "module description" @@ -117,56 +66,18 @@ module data_override_mod module procedure data_override_UG_2d end interface +integer :: atm_mode = 0 +integer :: ocn_mode = 0 +integer :: lnd_mode = 0 +integer :: ice_mode = 0 + !> @addtogroup data_override_mod !> @{ - integer, parameter :: max_table=100, max_array=100 - real, parameter :: deg_to_radian=PI/180. - integer :: table_size !< actual size of data table - logical :: module_is_initialized = .FALSE. - -type(domain2D),save :: ocn_domain,atm_domain,lnd_domain, ice_domain -type(domainUG),save :: lnd_domainUG - -real, dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn -real, dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm -real, dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice -real, dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd -real :: min_glo_lon_ocn, max_glo_lon_ocn -real :: min_glo_lon_atm, max_glo_lon_atm -real :: min_glo_lon_lnd, max_glo_lon_lnd -real :: min_glo_lon_ice, max_glo_lon_ice -integer:: num_fields = 0 !< number of fields in override_array already processed -#ifdef use_yaml -type(data_type), dimension(:), allocatable :: data_table !< user-provided data table -#else -type(data_type), dimension(max_table) :: data_table !< user-provided data table -#endif - -type(data_type) :: default_table -type(override_type), dimension(max_array), save :: override_array !< to store processed fields -type(override_type), save :: default_array -logical :: atm_on, ocn_on, lnd_on, ice_on -logical :: lndUG_on -logical :: debug_data_override -logical :: grid_center_bug = .false. -logical :: reproduce_null_char_bug = .false. !> Flag indicating - !! to reproduce the mpp_io bug where lat/lon_bnd were - !! not read correctly if null characters are present in - !! the netcdf file - -namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug - public :: data_override_init, data_override, data_override_unset_domains public :: data_override_UG contains -function count_ne_1(in_1, in_2, in_3) - logical, intent(in) :: in_1, in_2, in_3 - logical :: count_ne_1 - - count_ne_1 = .not.(in_1.NEQV.in_2.NEQV.in_3) .OR. (in_1.AND.in_2.AND.in_3) -end function count_ne_1 !> @brief Assign default values for default_table, get domain of component models, !! get global grids of component models. @@ -182,381 +93,35 @@ end function count_ne_1 !! Data_table is initialized here with default values. Users should provide "real" values !! that will override the default values. Real values can be given using data_table, each !! line of data_table contains one data_entry. Items of data_entry are comma separated. -subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) +subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in, mode) type (domain2d), intent(in), optional :: Atm_domain_in type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in type (domain2d), intent(in), optional :: Land_domain_in type(domainUG) , intent(in), optional :: Land_domainUG_in + integer, intent(in), optional :: mode !< r4_kind or r8_kind + integer :: mode_selector - character(len=128) :: grid_file = 'INPUT/grid_spec.nc' - integer :: is,ie,js,je,use_get_grid_version - integer :: i, unit, io_status, ierr - logical :: file_open - type(FmsNetcdfFile_t) :: fileobj - - debug_data_override = .false. - - read (input_nml_file, data_override_nml, iostat=io_status) - ierr = check_nml_error(io_status, 'data_override_nml') - unit = stdlog() - write(unit, data_override_nml) - -! grid_center_bug is no longer supported. -if (grid_center_bug) then - call mpp_error(FATAL, "data_override_init: You have overridden the default value of " // & - "grid_center_bug and set it to .true. in data_override_nml. This was a temporary workaround " // & - "that is no longer supported. Please remove this namelist variable.") -endif - -! if(module_is_initialized) return - - atm_on = PRESENT(Atm_domain_in) - ocn_on = PRESENT(Ocean_domain_in) - lnd_on = PRESENT(Land_domain_in) - ice_on = PRESENT(Ice_domain_in) - lndUG_on = PRESENT(Land_domainUG_in) - if(.not. module_is_initialized) then - atm_domain = NULL_DOMAIN2D - ocn_domain = NULL_DOMAIN2D - lnd_domain = NULL_DOMAIN2D - ice_domain = NULL_DOMAIN2D - lnd_domainUG = NULL_DOMAINUG - end if - if (atm_on) atm_domain = Atm_domain_in - if (ocn_on) ocn_domain = Ocean_domain_in - if (lnd_on) lnd_domain = Land_domain_in - if (ice_on) ice_domain = Ice_domain_in - if (lndUG_on) lnd_domainUG = Land_domainUG_in - - if(.not. module_is_initialized) then - call horiz_interp_init - call write_version_number("DATA_OVERRIDE_MOD", version) - -! Initialize user-provided data table - default_table%gridname = 'non' - default_table%fieldname_code = 'none' - default_table%fieldname_file = 'none' - default_table%file_name = 'none' - default_table%factor = 1. - default_table%interpol_method = 'bilinear' - -#ifdef use_yaml - call read_table_yaml(data_table) -#else - do i = 1,max_table - data_table(i) = default_table - enddo - call read_table(data_table) -#endif - -! Initialize override array - default_array%gridname = 'NONE' - default_array%fieldname = 'NONE' - default_array%t_index = -1 - default_array%dims = -1 - default_array%comp_domain = -1 - do i = 1, max_array - override_array(i) = default_array - enddo - call time_interp_external_init - end if - - module_is_initialized = .TRUE. - - if ( .NOT. (atm_on .or. ocn_on .or. lnd_on .or. ice_on .or. lndUG_on)) return - if (table_size .eq. 0) then - call mpp_error(NOTE, "data_table is empty, not doing any data_overrides") - return - endif - call fms2_io_init - -! Test if grid_file is already opened - inquire (file=trim(grid_file), opened=file_open) - if(file_open) call mpp_error(FATAL, trim(grid_file)//' already opened') - - if(.not. open_file(fileobj, grid_file, 'read' )) then - call mpp_error(FATAL, 'data_override_mod: Error in opening file '//trim(grid_file)) - endif - - if(variable_exists(fileobj, "x_T" ) .OR. variable_exists(fileobj, "geolon_t" ) ) then - use_get_grid_version = 1 - call close_file(fileobj) - else if(variable_exists(fileobj, "ocn_mosaic_file" ) .OR. variable_exists(fileobj, "gridfiles" ) ) then - use_get_grid_version = 2 - if(variable_exists(fileobj, "gridfiles" ) ) then - if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' //& - 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true') - end if - else - call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '// & - & trim(grid_file)) - endif - - if(use_get_grid_version .EQ. 1) then - if (atm_on .and. .not. allocated(lon_local_atm) ) then - call mpp_get_compute_domain( atm_domain,is,ie,js,je) - allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) - call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & - min_glo_lon_atm, max_glo_lon_atm ) - endif - if (ocn_on .and. .not. allocated(lon_local_ocn) ) then - call mpp_get_compute_domain( ocn_domain,is,ie,js,je) - allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) - call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & - min_glo_lon_ocn, max_glo_lon_ocn ) - endif - - if (lnd_on .and. .not. allocated(lon_local_lnd) ) then - call mpp_get_compute_domain( lnd_domain,is,ie,js,je) - allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) - call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & - min_glo_lon_lnd, max_glo_lon_lnd ) - endif - - if (ice_on .and. .not. allocated(lon_local_ice) ) then - call mpp_get_compute_domain( ice_domain,is,ie,js,je) - allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) - call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & - min_glo_lon_ice, max_glo_lon_ice ) - endif - else - if (atm_on .and. .not. allocated(lon_local_atm) ) then - call mpp_get_compute_domain(atm_domain,is,ie,js,je) - allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je)) - call get_grid_version_2(fileobj, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, & - min_glo_lon_atm, max_glo_lon_atm ) - endif - - if (ocn_on .and. .not. allocated(lon_local_ocn) ) then - call mpp_get_compute_domain( ocn_domain,is,ie,js,je) - allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je)) - call get_grid_version_2(fileobj, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, & - min_glo_lon_ocn, max_glo_lon_ocn ) - endif - - if (lnd_on .and. .not. allocated(lon_local_lnd) ) then - call mpp_get_compute_domain( lnd_domain,is,ie,js,je) - allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je)) - call get_grid_version_2(fileobj, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, & - min_glo_lon_lnd, max_glo_lon_lnd ) - endif + if (present(mode)) then + mode_selector = mode + else + mode_selector = r8_kind + endif - if (ice_on .and. .not. allocated(lon_local_ice) ) then - call mpp_get_compute_domain( ice_domain,is,ie,js,je) - allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je)) - call get_grid_version_2(fileobj, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, & - min_glo_lon_ice, max_glo_lon_ice ) - endif - end if - if(use_get_grid_version .EQ. 2) then - call close_file(fileobj) - end if + select case (mode_selector) + case (r4_kind) + call data_override_init_r4(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) + case (r8_kind) + call data_override_init_r8(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) + case default + call mpp_error(FATAL, "data_override_init: unsupported mode argument") + end select + if (present(Atm_domain_in)) atm_mode = mode + if (present(Ocean_domain_in)) ocn_mode = mode + if (present(Ice_domain_in)) ice_mode = mode + if (present(Land_domain_in)) lnd_mode = mode end subroutine data_override_init -#ifndef use_yaml -subroutine read_table(data_table) - type(data_type), dimension(max_table), intent(inout) :: data_table - - integer :: ntable - integer :: ntable_lima - integer :: ntable_new - - integer :: iunit - integer :: io_status - character(len=256) :: record - type(data_type) :: data_entry - - logical :: ongrid - logical :: table_exists !< Flag indicating existence of data_table - character(len=128) :: region, region_type - - integer :: sunit - -! Read coupler_table - inquire(file='data_table', EXIST=table_exists) - if (.not. table_exists) then - call mpp_error(NOTE, 'data_override_mod: File data_table does not exist.') - table_size = 0 - return - end if - - open(newunit=iunit, file='data_table', action='READ', iostat=io_status) - if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in opening file data_table.') - - ntable = 0 - ntable_lima = 0 - ntable_new = 0 - - do while (ntable <= max_table) - read(iunit,'(a)',end=100) record - if (record(1:1) == '#') cycle - if (record(1:10) == ' ') cycle - ntable=ntable+1 - if(index(lowercase(record), "inside_region") .ne. 0 .or. index(lowercase(record), "outside_region") .ne. 0) then - if(index(lowercase(record), ".false.") .ne. 0 .or. index(lowercase(record), ".true.") .ne. 0 ) then - ntable_lima = ntable_lima + 1 - read(record,*,err=99) data_entry%gridname, data_entry%fieldname_code, data_entry%fieldname_file, & - data_entry%file_name, ongrid, data_entry%factor, region, region_type - if(ongrid) then - data_entry%interpol_method = 'none' - else - data_entry%interpol_method = 'bilinear' - endif - else - ntable_new=ntable_new+1 - read(record,*,err=99) data_entry%gridname, data_entry%fieldname_code, data_entry%fieldname_file, & - data_entry%file_name, data_entry%interpol_method, data_entry%factor, region, & - & region_type - if (data_entry%interpol_method == 'default') then - data_entry%interpol_method = default_table%interpol_method - endif - if (.not.(data_entry%interpol_method == 'default' .or. & - data_entry%interpol_method == 'bicubic' .or. & - data_entry%interpol_method == 'bilinear' .or. & - data_entry%interpol_method == 'none')) then - sunit = stdout() - write(sunit,*)" gridname is ", trim(data_entry%gridname) - write(sunit,*)" fieldname_code is ", trim(data_entry%fieldname_code) - write(sunit,*)" fieldname_file is ", trim(data_entry%fieldname_file) - write(sunit,*)" file_name is ", trim(data_entry%file_name) - write(sunit,*)" factor is ", data_entry%factor - write(sunit,*)" interpol_method is ", trim(data_entry%interpol_method) - call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' & - //'its value should be "default", "bicubic", "bilinear" or "none" ') - endif - endif - if( trim(region_type) == "inside_region" ) then - data_entry%region_type = INSIDE_REGION - else if( trim(region_type) == "outside_region" ) then - data_entry%region_type = OUTSIDE_REGION - else - call mpp_error(FATAL, 'data_override_mod: region type should be inside_region or outside_region') - endif - if (data_entry%file_name == "") call mpp_error(FATAL, & - "data_override: filename not given in data_table when region_type is not NO_REGION") - if(data_entry%fieldname_file == "") call mpp_error(FATAL, & - "data_override: fieldname_file must be specified in data_table when region_type is not NO_REGION") - if( trim(data_entry%interpol_method) == 'none') call mpp_error(FATAL, & - "data_override(data_override_init): ongrid must be false when region_type is not NO_REGION") - read(region,*) data_entry%lon_start, data_entry%lon_end, data_entry%lat_start, data_entry%lat_end - !--- make sure data_entry%lon_end > data_entry%lon_start and data_entry%lat_end > data_entry%lat_start - if(data_entry%lon_end .LE. data_entry%lon_start) call mpp_error(FATAL, & - "data_override: lon_end should be greater than lon_start") - if(data_entry%lat_end .LE. data_entry%lat_start) call mpp_error(FATAL, & - "data_override: lat_end should be greater than lat_start") - ! old format - else if (index(lowercase(record), ".false.") .ne. 0 .or. index(lowercase(record), ".true.") .ne. 0 ) then - ntable_lima = ntable_lima + 1 - read(record,*,err=99) data_entry%gridname, data_entry%fieldname_code, data_entry%fieldname_file, & - data_entry%file_name, ongrid, data_entry%factor - if(ongrid) then - data_entry%interpol_method = 'none' - else - data_entry%interpol_method = 'bilinear' - endif - data_entry%lon_start = 0.0 - data_entry%lon_end = -1.0 - data_entry%lat_start = 0.0 - data_entry%lat_end = -1.0 - data_entry%region_type = NO_REGION - else ! new format - ntable_new=ntable_new+1 - read(record,*,err=99) data_entry%gridname, data_entry%fieldname_code, data_entry%fieldname_file, & - data_entry%file_name, data_entry%interpol_method, data_entry%factor - if (data_entry%interpol_method == 'default') then - data_entry%interpol_method = default_table%interpol_method - endif - if (.not.(data_entry%interpol_method == 'default' .or. & - data_entry%interpol_method == 'bicubic' .or. & - data_entry%interpol_method == 'bilinear' .or. & - data_entry%interpol_method == 'none')) then - sunit = stdout() - write(sunit,*)" gridname is ", trim(data_entry%gridname) - write(sunit,*)" fieldname_code is ", trim(data_entry%fieldname_code) - write(sunit,*)" fieldname_file is ", trim(data_entry%fieldname_file) - write(sunit,*)" file_name is ", trim(data_entry%file_name) - write(sunit,*)" factor is ", data_entry%factor - write(sunit,*)" interpol_method is ", trim(data_entry%interpol_method) - call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' & - //'its value should be "default", "bicubic", "bilinear" or "none" ') - endif - data_entry%lon_start = 0.0 - data_entry%lon_end = -1.0 - data_entry%lat_start = 0.0 - data_entry%lat_end = -1.0 - data_entry%region_type = NO_REGION - endif - data_table(ntable) = data_entry - enddo - call mpp_error(FATAL,'too many enries in data_table') -99 call mpp_error(FATAL,'error in data_table format') -100 continue - table_size = ntable - if(ntable_new*ntable_lima /= 0) call mpp_error(FATAL, & - 'data_override_mod: New and old formats together in same data_table not supported') - close(iunit, iostat=io_status) - if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in closing file data_table') -end subroutine read_table - -#else -subroutine read_table_yaml(data_table) - type(data_type), dimension(:), allocatable, intent(out) :: data_table - - integer, allocatable :: entry_id(:) - integer :: nentries - integer :: i - character(len=50) :: buffer - integer :: file_id - - file_id = open_and_parse_file("data_table.yaml") - if (file_id==999) then - nentries = 0 - else - nentries = get_num_blocks(file_id, "data_table") - allocate(data_table(nentries)) - allocate(entry_id(nentries)) - call get_block_ids(file_id, "data_table", entry_id) - - do i = 1, nentries - call get_value_from_key(file_id, entry_id(i), "gridname", data_table(i)%gridname) - call get_value_from_key(file_id, entry_id(i), "fieldname_code", data_table(i)%fieldname_code) - - 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)%file_name = "" - call get_value_from_key(file_id, entry_id(i), "file_name", data_table(i)%file_name, & - & is_optional=.true.) - - 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 get_value_from_key(file_id, entry_id(i), "factor", data_table(i)%factor) - call get_value_from_key(file_id, entry_id(i), "region_type", buffer, is_optional=.true.) - - if(trim(buffer) == "inside_region" ) then - data_table(i)%region_type = INSIDE_REGION - else if( trim(buffer) == "outside_region" ) then - data_table(i)%region_type = OUTSIDE_REGION - else - data_table(i)%region_type = NO_REGION - endif - - 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.) - - end do - - end if - table_size = nentries !< Because one variable is not enough -end subroutine read_table_yaml -#endif - !> @brief Unset domains that had previously been set for use by data_override. !! !! This subroutine deallocates any data override domains that have been set. @@ -569,88 +134,75 @@ subroutine data_override_unset_domains(unset_Atm, unset_Ocean, & fail_if_not_set = .true. ; if (present(must_be_set)) fail_if_not_set = must_be_set - if (.not.module_is_initialized) call mpp_error(FATAL, & - "data_override_unset_domains called with an unititialized data_override module.") - - if (PRESENT(unset_Atm)) then ; if (unset_Atm) then - if (fail_if_not_set .and. .not.atm_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Atm_domain that had not been set.") - atm_domain = NULL_DOMAIN2D - atm_on = .false. - if (allocated(lon_local_atm)) deallocate(lon_local_atm) - if (allocated(lat_local_atm)) deallocate(lat_local_atm) + if (present(unset_Atm)) then ; if (unset_Atm) then + select case (atm_mode) + case (r4_kind) + call data_override_unset_atm_r4 + case (r8_kind) + call data_override_unset_atm_r8 + case default + if (fail_if_not_set) call mpp_error(FATAL, & + "data_override_unset_domains: attempted to unset an Atm_domain that has not been set.") + end select + atm_mode = 0 endif ; endif - if (PRESENT(unset_Ocean)) then ; if (unset_Ocean) then - if (fail_if_not_set .and. .not.ocn_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Ocn_domain that had not been set.") - ocn_domain = NULL_DOMAIN2D - ocn_on = .false. - if (allocated(lon_local_ocn)) deallocate(lon_local_ocn) - if (allocated(lat_local_ocn)) deallocate(lat_local_ocn) + if (present(unset_Ocean)) then ; if (unset_Ocean) then + select case (ocn_mode) + case (r4_kind) + call data_override_unset_ocn_r4 + case (r8_kind) + call data_override_unset_ocn_r8 + case default + if (fail_if_not_set) call mpp_error(FATAL, & + "data_override_unset_domains: attempted to unset an Ocn_domain that has not been set.") + end select + ocn_mode = 0 endif ; endif - if (PRESENT(unset_Land)) then ; if (unset_Land) then - if (fail_if_not_set .and. .not.lnd_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on a Land_domain that had not been set.") - lnd_domain = NULL_DOMAIN2D - lnd_on = .false. - if (allocated(lon_local_lnd)) deallocate(lon_local_lnd) - if (allocated(lat_local_lnd)) deallocate(lat_local_lnd) + if (present(unset_Land)) then ; if (unset_Land) then + select case (lnd_mode) + case (r4_kind) + call data_override_unset_lnd_r4 + case (r8_kind) + call data_override_unset_lnd_r8 + case default + if (fail_if_not_set) call mpp_error(FATAL, & + "data_override_unset_domains: attempted to unset an Land_domain that has not been set.") + end select + lnd_mode = 0 endif ; endif - if (PRESENT(unset_Ice)) then ; if (unset_Ice) then - if (fail_if_not_set .and. .not.ice_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Ice_domain that had not been set.") - ice_domain = NULL_DOMAIN2D - ice_on = .false. - if (allocated(lon_local_ice)) deallocate(lon_local_ice) - if (allocated(lat_local_ice)) deallocate(lat_local_ice) + if (present(unset_Ice)) then ; if (unset_Ice) then + select case (ice_mode) + case (r4_kind) + call data_override_unset_ice_r4 + case (r8_kind) + call data_override_unset_ice_r8 + case default + if (fail_if_not_set) call mpp_error(FATAL, & + "data_override_unset_domains: attempted to unset an Ice_domain that has not been set.") + end select + ice_mode = 0 endif ; endif - end subroutine data_override_unset_domains -!> @brief Given a gridname, this routine returns the working domain associated with this gridname -subroutine get_domain(gridname, domain, comp_domain) - character(len=3), intent(in) :: gridname - type(domain2D), intent(inout) :: domain - integer, intent(out), optional :: comp_domain(4) !< istart,iend,jstart,jend for compute domain - - domain = NULL_DOMAIN2D - select case (gridname) - case('OCN') - domain = ocn_domain - case('ATM') - domain = atm_domain - case('LND') - domain = lnd_domain - case('ICE') - domain = ice_domain - case default - call mpp_error(FATAL,'error in data_override get_domain') - end select - if(domain .EQ. NULL_DOMAIN2D) call mpp_error(FATAL,'data_override: failure in get_domain') - if(present(comp_domain)) & - call mpp_get_compute_domain(domain,comp_domain(1),comp_domain(2),comp_domain(3),comp_domain(4)) -end subroutine get_domain - -!> @brief Given a gridname, this routine returns the working domain associated with this gridname -subroutine get_domainUG(gridname, UGdomain, comp_domain) - character(len=3), intent(in) :: gridname - type(domainUG), intent(inout) :: UGdomain - integer, intent(out), optional :: comp_domain(4) !< istart,iend,jstart,jend for compute domain - type(domain2D), pointer :: SGdomain => NULL() +!> @brief Routine to perform data override for scalar fields +subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_index) + character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) + character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be + !! different from the name in NetCDF data file) + logical, intent(out), optional :: override !< true if the field has been overriden succesfully + type(time_type), intent(in) :: time !< (target) model time + class(*), intent(out) :: data !< output data array returned by this call + integer, intent(in), optional :: data_index - UGdomain = NULL_DOMAINUG - select case (gridname) - case('LND') - UGdomain = lnd_domainUG - case default - call mpp_error(FATAL,'error in data_override get_domain') + select type(data) + type is (real(r4_kind)) + call data_override_0d_r4(gridname,fieldname_code,data,time,override,data_index) + type is (real(r8_kind)) + call data_override_0d_r8(gridname,fieldname_code,data,time,override,data_index) + class default + call mpp_error(FATAL, "data_override_0d: Unsupported data type") end select -! if(UGdomain .EQ. NULL_DOMAINUG) call mpp_error(FATAL,'data_override: failure in get_domain') - if(present(comp_domain)) & - call mpp_get_UG_SG_domain(UGdomain,SGdomain) - call mpp_get_compute_domain(SGdomain,comp_domain(1),comp_domain(2),comp_domain(3),comp_domain(4)) -end subroutine get_domainUG -!=============================================================================================== +end subroutine data_override_0d !> @brief This routine performs data override for 2D fields; for usage, see data_override_3d. subroutine data_override_2d(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) @@ -658,31 +210,17 @@ subroutine data_override_2d(gridname,fieldname,data_2D,time,override, is_in, ie_ character(len=*), intent(in) :: fieldname !< field to override logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< model time - real, dimension(:,:), intent(inout) :: data_2D !< data returned by this call + class(*), dimension(:,:), intent(inout) :: data_2D !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in -! real, dimension(size(data_2D,1),size(data_2D,2),1) :: data_3D - real, dimension(:,:,:), allocatable :: data_3D - integer :: index1 - integer :: i -!1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) return ! NO override was performed - - allocate(data_3D(size(data_2D,1),size(data_2D,2),1)) - data_3D(:,:,1) = data_2D - call data_override_3d(gridname,fieldname,data_3D,time,override,data_index=index1,& - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in) - - data_2D(:,:) = data_3D(:,:,1) - deallocate(data_3D) + select type(data_2D) + type is (real(r4_kind)) + call data_override_2d_r4(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) + type is (real(r8_kind)) + call data_override_2d_r8(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) + class default + call mpp_error(FATAL, "data_override_2d: Unsupported data type") + end select end subroutine data_override_2d !> @brief This routine performs data override for 3D fields @@ -692,610 +230,53 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde logical, optional, intent(out) :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time integer, optional, intent(in) :: data_index - real, dimension(:,:,:), intent(inout) :: data !< data returned by this call + class(*), dimension(:,:,:), intent(inout) :: data !< data returned by this call 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=128) :: fieldname !< fieldname used in the data file - integer :: i,j - integer :: dims(4) - integer :: index1 !< field index in data_table - integer :: id_time !< index for time interp in override array - integer :: axis_sizes(4) - character(len=32) :: axis_names(4) - real, dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells - real, dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells - real, dimension(:), allocatable :: lon_tmp, lat_tmp - - logical :: data_file_is_2D = .false. !< data in netCDF file is 2D - logical :: ongrid, use_comp_domain - type(domain2D) :: domain - integer :: curr_position !< position of the field currently processed in override_array - real :: factor - integer, dimension(4) :: comp_domain = 0 !< istart,iend,jstart,jend for compute domain - integer :: nxd, nyd, nxc, nyc, nwindows - integer :: nwindows_x, ipos, jpos, window_size(2) - integer :: istart, iend, jstart, jend - integer :: isw, iew, jsw, jew - integer :: omp_get_num_threads, window_id - logical :: need_compute - real :: lat_min, lat_max - integer :: is_src, ie_src, js_src, je_src - logical :: exists - type(FmsNetcdfFile_t) :: fileobj - integer :: startingi !< Starting x index for the compute domain relative to the input buffer - integer :: endingi !< Ending x index for the compute domain relative to the input buffer - integer :: startingj !< Starting y index for the compute domain relative to the input buffer - 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 - - use_comp_domain = .false. - if(.not.module_is_initialized) & - call mpp_error(FATAL,'Error: need to call data_override_init first') - -!1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - if (present(data_index)) then - index1 = data_index - else - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) then - if(debug_data_override) & - call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code)) - return ! NO override was performed - endif - endif - - fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file - factor = data_table(index1)%factor - - if(fieldname == "") then - data = factor - if(PRESENT(override)) override = .true. - return - else - filename = data_table(index1)%file_name - if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table') - endif - - ongrid = (data_table(index1)%interpol_method == 'none') - -!3 Check if fieldname has been previously processed -!$OMP CRITICAL - curr_position = -1 - if(num_fields > 0 ) then - do i = 1, num_fields - if(trim(override_array(i)%gridname) /= trim(gridname)) cycle - if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle - curr_position = i - exit - enddo - endif - - if(curr_position < 0) then ! the field has not been processed previously - num_fields = num_fields + 1 - curr_position = num_fields - -! Get working domain from model's gridname - call get_domain(gridname,domain,comp_domain) - call mpp_get_data_domain(domain, xsize=nxd, ysize=nyd) - nxc = comp_domain(2)-comp_domain(1) + 1 - nyc = comp_domain(4)-comp_domain(3) + 1 - -! record fieldname, gridname in override_array - override_array(curr_position)%fieldname = fieldname_code - override_array(curr_position)%gridname = gridname - override_array(curr_position)%comp_domain = comp_domain -! get number of threads - override_array(curr_position)%numthreads = 1 -#if defined(_OPENMP) - override_array(curr_position)%numthreads = omp_get_num_threads() -#endif -!--- data_override may be called from physics windows. The following are possible situations -!--- 1. size(data,1) == nxd and size(data,2) == nyd ( on data domain and there is only one window). -!--- 2. nxc is divisible by size(data,1), nyc is divisible by size(data,2), -!--- nwindow = (nxc/size(data(1))*(nyc/size(data,2)), also we require nwindows is divisible by nthreads. -!--- The another restrition is that size(data,1) == ie_in - is_in + 1, -!--- size(data,2) == je_in - js_in + 1 - nwindows = 1 - if( nxd == size(data,1) .AND. nyd == size(data,2) ) then ! - use_comp_domain = .false. - else if ( mod(nxc, size(data,1)) ==0 .AND. mod(nyc, size(data,2)) ==0 ) then - use_comp_domain = .true. - nwindows = (nxc/size(data,1))*(nyc/size(data,2)) - else - call mpp_error(FATAL, & - & "data_override: data is not on data domain and compute domain is not divisible by size(data)") - endif - override_array(curr_position)%window_size(1) = size(data,1) - override_array(curr_position)%window_size(2) = size(data,2) - - window_size = override_array(curr_position)%window_size - override_array(curr_position)%numwindows = nwindows - if( mod(nwindows, override_array(curr_position)%numthreads) .NE. 0 ) then - call mpp_error(FATAL, "data_override: nwindow is not divisible by nthreads") - endif - allocate(override_array(curr_position)%need_compute(nwindows)) - override_array(curr_position)%need_compute = .true. - -!4 get index for time interp - if(ongrid) then - if( data_table(index1)%region_type .NE. NO_REGION ) then - call mpp_error(FATAL,'data_override: ongrid must be false when region_type .NE. NO_REGION') - endif - -! Allow on-grid data_overrides on cubed sphere grid - inquire(file=trim(filename),EXIST=exists) - if (.not. exists) then - call get_mosaic_tile_file(filename,filename2,.false.,domain) - filename = filename2 - endif - - !--- we always only pass data on compute domain - id_time = init_external_field(filename,fieldname,domain=domain,verbose=.false., & - use_comp_domain=use_comp_domain, nwindows=nwindows, ongrid=ongrid) - dims = get_external_field_size(id_time) - override_array(curr_position)%dims = dims - if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') - override_array(curr_position)%t_index = id_time - else !ongrid=false - id_time = init_external_field(filename,fieldname,domain=domain, axis_names=axis_names,& - axis_sizes=axis_sizes, verbose=.false.,override=.true.,use_comp_domain=use_comp_domain, & - nwindows = nwindows) - dims = get_external_field_size(id_time) - override_array(curr_position)%dims = dims - if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 2') - override_array(curr_position)%t_index = id_time - - ! get lon and lat of the input (source) grid, assuming that axis%data contains - ! lat and lon of the input grid (in degrees) - - allocate(override_array(curr_position)%horz_interp(nwindows)) - allocate(override_array(curr_position)%lon_in(axis_sizes(1)+1)) - allocate(override_array(curr_position)%lat_in(axis_sizes(2)+1)) - if(get_external_fileobj(filename, fileobj)) then - call axis_edges(fileobj, axis_names(1), override_array(curr_position)%lon_in, & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - call axis_edges(fileobj, axis_names(2), override_array(curr_position)%lat_in, & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - else - call mpp_error(FATAL,'data_override: file '//trim(filename)//' is not opened in time_interp_external') - end if -! convert lon_in and lat_in from deg to radian - override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * deg_to_radian - override_array(curr_position)%lat_in = override_array(curr_position)%lat_in * deg_to_radian - - !--- find the region of the source grid that cover the local model grid. - !--- currently we only find the index range for j-direction because - !--- of the cyclic condition in i-direction. The purpose of this is to - !--- decrease the memory usage and increase the IO performance. - select case(gridname) - case('OCN') - lon_local => lon_local_ocn; lat_local => lat_local_ocn - case('ICE') - lon_local => lon_local_ice; lat_local => lat_local_ice - case('ATM') - lon_local => lon_local_atm; lat_local => lat_local_atm - case('LND') - lon_local => lon_local_lnd; lat_local => lat_local_lnd - case default - call mpp_error(FATAL,'error: gridname not recognized in data_override') - end select - - lat_min = minval(lat_local) - lat_max = maxval(lat_local) - is_src = 1 - ie_src = axis_sizes(1) - js_src = 1 - je_src = axis_sizes(2) - do j = 1, axis_sizes(2)+1 - if( override_array(curr_position)%lat_in(j) > lat_min ) exit - js_src = j - enddo - do j = 1, axis_sizes(2)+1 - je_src = j - if( override_array(curr_position)%lat_in(j) > lat_max ) exit - enddo - - !--- bicubic interpolation need one extra point in each direction. Also add - !--- one more point for because lat_in is in the corner but the interpolation - !--- use center points. - select case (data_table(index1)%interpol_method) - case ('bilinear') - js_src = max(1, js_src-1) - je_src = min(axis_sizes(2), je_src+1) - case ('bicubic') - js_src = max(1, js_src-2) - je_src = min(axis_sizes(2), je_src+2) - end select - override_array(curr_position)%is_src = is_src - override_array(curr_position)%ie_src = ie_src - override_array(curr_position)%js_src = js_src - override_array(curr_position)%je_src = je_src - call reset_src_data_region(id_time, is_src, ie_src, js_src, je_src) - -! Find the index of lon_start, lon_end, lat_start and lat_end in the input grid (nearest points) - if( data_table(index1)%region_type .NE. NO_REGION ) then - allocate( lon_tmp(axis_sizes(1)), lat_tmp(axis_sizes(2)) ) - call read_data(fileobj, axis_names(1), lon_tmp) - call read_data(fileobj, axis_names(2), lat_tmp) - ! limit lon_start, lon_end are inside lon_in - ! lat_start, lat_end are inside lat_in - if(data_table(index1)%lon_start < lon_tmp(1) .OR. data_table(index1)%lon_start .GT. lon_tmp(axis_sizes(1)))& - call mpp_error(FATAL, "data_override: lon_start is outside lon_T") - if( data_table(index1)%lon_end < lon_tmp(1) .OR. data_table(index1)%lon_end .GT. lon_tmp(axis_sizes(1))) & - call mpp_error(FATAL, "data_override: lon_end is outside lon_T") - if(data_table(index1)%lat_start < lat_tmp(1) .OR. data_table(index1)%lat_start .GT. lat_tmp(axis_sizes(2)))& - call mpp_error(FATAL, "data_override: lat_start is outside lat_T") - if( data_table(index1)%lat_end < lat_tmp(1) .OR. data_table(index1)%lat_end .GT. lat_tmp(axis_sizes(2))) & - call mpp_error(FATAL, "data_override: lat_end is outside lat_T") - istart = nearest_index(data_table(index1)%lon_start, lon_tmp) - iend = nearest_index(data_table(index1)%lon_end, lon_tmp) - jstart = nearest_index(data_table(index1)%lat_start, lat_tmp) - jend = nearest_index(data_table(index1)%lat_end, lat_tmp) - ! adjust the index according to is_src and js_src - istart = istart - is_src + 1 - iend = iend - is_src + 1 - jstart = jstart - js_src + 1 - jend = jend - js_src + 1 - call set_override_region(id_time, data_table(index1)%region_type, istart, iend, jstart, jend) - deallocate(lon_tmp, lat_tmp) - endif - - endif - else !curr_position >0 - dims = override_array(curr_position)%dims - comp_domain = override_array(curr_position)%comp_domain - nxc = comp_domain(2)-comp_domain(1) + 1 - nyc = comp_domain(4)-comp_domain(3) + 1 - is_src = override_array(curr_position)%is_src - ie_src = override_array(curr_position)%ie_src - js_src = override_array(curr_position)%js_src - je_src = override_array(curr_position)%je_src - window_size = override_array(curr_position)%window_size - !---make sure data size match window_size - if( window_size(1) .NE. size(data,1) .OR. window_size(2) .NE. size(data,2) ) then - call mpp_error(FATAL, "data_override: window_size does not match size(data)") - endif -!9 Get id_time previously stored in override_array - id_time = override_array(curr_position)%t_index - endif -!$OMP END CRITICAL - - if( override_array(curr_position)%numwindows > 1 ) then - if( .NOT. PRESENT(is_in) .OR. .NOT. PRESENT(is_in) .OR. .NOT. PRESENT(is_in) .OR. .NOT. PRESENT(is_in) ) then - call mpp_error(FATAL, "data_override: is_in, ie_in, js_in, je_in must be present when nwindows > 1") - endif - endif - - isw = comp_domain(1) - iew = comp_domain(2) - jsw = comp_domain(3) - jew = comp_domain(4) - window_id = 1 - if( override_array(curr_position)%numwindows > 1 ) then - nxc = comp_domain(2) - comp_domain(1) + 1 - nwindows_x = nxc/window_size(1) - ipos = (is_in-1)/window_size(1) + 1 - jpos = (js_in-1)/window_size(2) - - window_id = jpos*nwindows_x + ipos - isw = isw + is_in - 1 - iew = isw + ie_in - is_in - jsw = jsw + js_in - 1 - jew = jsw + je_in - js_in - endif - - if( ongrid ) then - need_compute = .false. - else - !--- find the index for windows. - need_compute=override_array(curr_position)%need_compute(window_id) - endif - - !--- call horiz_interp_new is not initialized - - if( need_compute ) then - select case(gridname) - case('OCN') - lon_local => lon_local_ocn; lat_local => lat_local_ocn - case('ICE') - lon_local => lon_local_ice; lat_local => lat_local_ice - case('ATM') - lon_local => lon_local_atm; lat_local => lat_local_atm - case('LND') - lon_local => lon_local_lnd; lat_local => lat_local_lnd - case default - call mpp_error(FATAL,'error: gridname not recognized in data_override') - end select - - 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') - 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 - override_array(curr_position)%need_compute(window_id) = .false. - endif - - ! Determine if data in netCDF file is 2D or not - data_file_is_2D = .false. - if((dims(3) == 1) .and. (size(data,3)>1)) data_file_is_2D = .true. - - if(dims(3) .NE. 1 .and. (size(data,3) .NE. dims(3))) & - call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(data,3) .NE. dims(3)") - - if(ongrid) then - if (.not. use_comp_domain) then - !< Determine the size of the halox and the part of `data` that is in the compute domain - nhalox = (size(data,1) - nxc)/2 - nhaloy = (size(data,2) - nyc)/2 - startingi = lbound(data,1) + nhalox - startingj = lbound(data,2) + nhaloy - endingi = ubound(data,1) - nhalox - endingj = ubound(data,2) - nhaloy - end if - -!10 do time interp to get data in compute_domain - if(data_file_is_2D) then - if (use_comp_domain) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - else - !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct - !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,1),verbose=.false., & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - end if - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) - end do - else - if (use_comp_domain) then - call time_interp_external(id_time,time,data,verbose=.false., & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - else - !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct - !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,:),verbose=.false., & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - end if - data = data*factor - endif - else ! off grid case -! do time interp to get global data - if(data_file_is_2D) then - if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & - horz_interp=override_array(curr_position)%horz_interp(window_id), & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) - enddo - else - allocate(mask_out(size(data,1), size(data,2),1)) - mask_out = .false. - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & - horz_interp=override_array(curr_position)%horz_interp(window_id), & - mask_out =mask_out(:,:,1), & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - where(mask_out(:,:,1)) - data(:,:,1) = data(:,:,1)*factor - end where - do i = 2, size(data,3) - where(mask_out(:,:,1)) - data(:,:,i) = data(:,:,1) - end where - enddo - deallocate(mask_out) - endif - else - if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data,verbose=.false., & - horz_interp=override_array(curr_position)%horz_interp(window_id), & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data = data*factor - else - allocate(mask_out(size(data,1), size(data,2), size(data,3)) ) - mask_out = .false. - call time_interp_external(id_time,time,data,verbose=.false., & - horz_interp=override_array(curr_position)%horz_interp(window_id), & - mask_out =mask_out, & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - where(mask_out) - data = data*factor - end where - deallocate(mask_out) - endif - endif - - endif - - if(PRESENT(override)) override = .true. + select type(data) + type is (real(r4_kind)) + call data_override_3d_r4(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) + type is (real(r8_kind)) + call data_override_3d_r8(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) + class default + call mpp_error(FATAL, "data_override_3d: Unsupported data type") + end select end subroutine data_override_3d -!> @brief Routine to perform data override for scalar fields -subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_index) - character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) - character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be - !! different from the name in NetCDF data file) - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - type(time_type), intent(in) :: time !< (target) model time - real, intent(out) :: data !< output data array returned by this call - integer, intent(in), optional :: data_index - - character(len=512) :: filename !< file containing source data - character(len=128) :: fieldname !< fieldname used in the data file - integer :: index1 !< field index in data_table - integer :: id_time !< index for time interp in override array - integer :: curr_position !< position of the field currently processed in override_array - integer :: i - real :: factor - - if(.not.module_is_initialized) & - call mpp_error(FATAL,'Error: need to call data_override_init first') - -!1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - if (present(data_index)) then - index1 = data_index - else - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) then - if(debug_data_override) & - call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code)) - return ! NO override was performed - endif - endif - - fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file - factor = data_table(index1)%factor - - if(fieldname == "") then - data = factor - if(PRESENT(override)) override = .true. - return - else - filename = data_table(index1)%file_name - if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table') - endif - -!3 Check if fieldname has been previously processed -!$OMP SINGLE - curr_position = -1 - if(num_fields > 0 ) then - do i = 1, num_fields - if(trim(override_array(i)%gridname) /= trim(gridname)) cycle - if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle - curr_position = i - exit - enddo - endif - - if(curr_position < 0) then ! the field has not been processed previously - num_fields = num_fields + 1 - curr_position = num_fields - ! record fieldname, gridname in override_array - override_array(curr_position)%fieldname = fieldname_code - override_array(curr_position)%gridname = gridname - id_time = init_external_field(filename,fieldname,verbose=.false.) - if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') - override_array(curr_position)%t_index = id_time - else !curr_position >0 - !9 Get id_time previously stored in override_array - id_time = override_array(curr_position)%t_index - endif !if curr_position < 0 - - !10 do time interp to get data in compute_domain - call time_interp_external(id_time, time, data, verbose=.false.) - data = data*factor -!$OMP END SINGLE - - if(PRESENT(override)) override = .true. - -end subroutine data_override_0d - -!> @brief Data override for 2D unstructured grids +!> @brief Data override for 1D unstructured grids subroutine data_override_UG_1d(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real, dimension(:), intent(inout) :: data !< data returned by this call + class(*), dimension(:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully - !local vars - real, dimension(:,:), allocatable :: data_SG - type(domainUG) :: UG_domain - integer :: index1 - integer :: i - integer, dimension(4) :: comp_domain = 0 !< istart,iend,jstart,jend for compute domain - - !1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) return ! NO override was performed - - call get_domainUG(gridname,UG_domain,comp_domain) - allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4))) - - call data_override_2d(gridname,fieldname,data_SG,time,override) - - call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) - - deallocate(data_SG) + select type(data) + type is (real(r4_kind)) + call data_override_UG_1d_r4(gridname,fieldname,data,time,override) + type is (real(r8_kind)) + call data_override_UG_1d_r8(gridname,fieldname,data,time,override) + class default + call mpp_error(FATAL, "data_override_UG_1d: Unsupported data type") + end select end subroutine data_override_UG_1d !> @brief Data override for 2D unstructured grids subroutine data_override_UG_2d(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real, dimension(:,:), intent(inout) :: data !< data returned by this call + class(*), dimension(:,:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully - !local vars - real, dimension(:,:,:), allocatable :: data_SG - real, dimension(:,:), allocatable :: data_UG - type(domainUG) :: UG_domain - integer :: index1 - integer :: i, nlevel, nlevel_max - integer, dimension(4) :: comp_domain = 0 !< istart,iend,jstart,jend for compute domain - -!1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) return ! NO override was performed - - nlevel = size(data,2) - nlevel_max = nlevel - call mpp_max(nlevel_max) - - call get_domainUG(gridname,UG_domain,comp_domain) - allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),nlevel_max)) - allocate(data_UG(size(data,1), nlevel_max)) - data_SG = 0.0 - call data_override_3d(gridname,fieldname,data_SG,time,override) - - call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:,:), data_UG(:,:)) - data(:,1:nlevel) = data_UG(:,1:nlevel) - - deallocate(data_SG, data_UG) + select type(data) + type is (real(r4_kind)) + call data_override_UG_2d_r4(gridname,fieldname,data,time,override) + type is (real(r8_kind)) + call data_override_UG_2d_r8(gridname,fieldname,data,time,override) + class default + call mpp_error(FATAL, "data_override_UG_2d: Unsupported data type") + end select end subroutine data_override_UG_2d end module data_override_mod diff --git a/data_override/data_override_impl.F90 b/data_override/data_override_impl.F90 new file mode 100644 index 0000000000..d47110e0df --- /dev/null +++ b/data_override/data_override_impl.F90 @@ -0,0 +1,2 @@ +#include "data_override_impl_r4.fh" +#include "data_override_impl_r8.fh" diff --git a/data_override/get_grid_version.F90 b/data_override/get_grid_version.F90 index 451c570d43..02107c7834 100644 --- a/data_override/get_grid_version.F90 +++ b/data_override/get_grid_version.F90 @@ -23,7 +23,8 @@ !> @addtogroup get_grid_version_mod !> @{ module get_grid_version_mod -use constants_mod, only: PI +use constants_mod, only: DEG_TO_RAD +use platform_mod, only: r4_kind, r8_kind 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 @@ -33,7 +34,16 @@ module get_grid_version_mod implicit none -real, parameter :: deg_to_radian=PI/180. +interface get_grid_version_1 + module procedure get_grid_version_1_r4 + module procedure get_grid_version_1_r8 +end interface get_grid_version_1 + +interface get_grid_version_2 + module procedure get_grid_version_2_r4 + module procedure get_grid_version_2_r8 +end interface get_grid_version_2 + contains !> Get lon and lat of three model (target) grids from grid_spec.nc @@ -60,232 +70,8 @@ subroutine check_grid_sizes(domain_name, Domain, nlon, nlat) endif end subroutine check_grid_sizes -!> Get global lon and lat of three model (target) grids, with a given file name -subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) - character(len=*), intent(in) :: grid_file !< name of grid file - character(len=*), intent(in) :: mod_name !< module name - type(domain2d), intent(in) :: domain !< 2D domain - integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isc:,jsc:), intent(out) :: lon, lat - real, intent(out) :: min_lon, max_lon - - integer :: i, j, siz(4) - integer :: nlon, nlat !< size of global lon and lat - real, dimension(:,:,:), allocatable :: lon_vert, lat_vert !< of OCN grid vertices - real, dimension(:), allocatable :: glon, glat !< lon and lat of 1-D grid of atm/lnd - logical :: is_new_grid - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg - character(len=3) :: xname, yname - integer :: start(2), nread(2) - type(FmsNetcdfDomainFile_t) :: fileobj - integer :: ndims !< Number of dimensions - - if(.not. open_file(fileobj, grid_file, 'read', domain )) then - call mpp_error(FATAL, 'data_override_mod(get_grid_version_1): Error in opening file '//trim(grid_file)) - endif - - call mpp_get_data_domain(domain, isd, ied, jsd, jed) - call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - - select case(mod_name) - case('ocn', 'ice') - is_new_grid = .FALSE. - if(variable_exists(fileobj, 'x_T')) then - is_new_grid = .true. - else if(variable_exists(fileobj, 'geolon_t')) then - is_new_grid = .FALSE. - else - call mpp_error(FATAL,'data_override: both x_T and geolon_t is not in the grid file '//trim(grid_file) ) - endif - - if(is_new_grid) then - ndims = get_variable_num_dimensions(fileobj, 'x_T') - call get_variable_size(fileobj, 'x_T', siz(1:ndims)) - nlon = siz(1); nlat = siz(2) - call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat) - allocate(lon_vert(isc:iec,jsc:jec,4), lat_vert(isc:iec,jsc:jec,4) ) - - call read_data(fileobj, 'x_vert_T', lon_vert) - call read_data(fileobj, 'y_vert_T', lat_vert) - -!2 Global lon and lat of ocean grid cell centers are determined from adjacent vertices - lon(:,:) = (lon_vert(:,:,1) + lon_vert(:,:,2) + lon_vert(:,:,3) + lon_vert(:,:,4))*0.25 - lat(:,:) = (lat_vert(:,:,1) + lat_vert(:,:,2) + lat_vert(:,:,3) + lat_vert(:,:,4))*0.25 - else - - ndims = get_variable_num_dimensions(fileobj, 'geolon_vert_t') - call get_variable_size(fileobj, 'geolon_vert_t', siz(1:ndims)) - nlon = siz(1) - 1; nlat = siz(2) - 1; - call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat) - - start(1) = isc; nread(1) = iec-isc+2 - start(2) = jsc; nread(2) = jec-jsc+2 - - allocate(lon_vert(isc:iec+1,jsc:jec+1,1)) - allocate(lat_vert(isc:iec+1,jsc:jec+1,1)) - - call read_data(fileobj, 'geolon_vert_t', lon_vert(:,:,1), corner=start, edge_lengths=nread) - call read_data(fileobj, 'geolat_vert_t', lat_vert(:,:,1), corner=start, edge_lengths=nread) - - do j = jsc, jec - do i = isc, iec - lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1) + & - lon_vert(i+1,j+1,1) + lon_vert(i,j+1,1))*0.25 - lat(i,j) = (lat_vert(i,j,1) + lat_vert(i+1,j,1) + & - lat_vert(i+1,j+1,1) + lat_vert(i,j+1,1))*0.25 - enddo - enddo - endif - deallocate(lon_vert) - deallocate(lat_vert) - case('atm', 'lnd') - if(trim(mod_name) == 'atm') then - xname = 'xta'; yname = 'yta' - else - xname = 'xtl'; yname = 'ytl' - endif - ndims = get_variable_num_dimensions(fileobj, xname) - call get_variable_size(fileobj, xname, siz(1:ndims)) - nlon = siz(1); allocate(glon(nlon)) - call read_data(fileobj, xname, glon) - - ndims = get_variable_num_dimensions(fileobj, xname) - call get_variable_size(fileobj, yname, siz(1:ndims)) - nlat = siz(1); allocate(glat(nlat)) - call read_data(fileobj, yname, glat) - call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat) - - is = isc - isg + 1; ie = iec - isg + 1 - js = jsc - jsg + 1; je = jec - jsg + 1 - do j = js, jec - do i = is, ie - lon(i,j) = glon(i) - lat(i,j) = glat(j) - enddo - enddo - deallocate(glon) - deallocate(glat) - case default - call mpp_error(FATAL, "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ") - end select - - call close_file(fileobj) - - ! convert from degree to radian - lon = lon * deg_to_radian - lat = lat* deg_to_radian - min_lon = minval(lon) - max_lon = maxval(lon) - call mpp_min(min_lon) - call mpp_max(max_lon) - - -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) - type(FmsNetcdfFile_t), intent(in) :: fileobj !< file object for grid file - character(len=*), intent(in) :: mod_name !< module name - type(domain2d), intent(in) :: domain !< 2D domain - integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isc:,jsc:), intent(out) :: lon, lat - real, intent(out) :: min_lon, max_lon - - integer :: i, j, siz(2) - integer :: nlon, nlat ! size of global grid - integer :: nlon_super, nlat_super ! size of global supergrid. - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg - integer :: isc2, iec2, jsc2, jec2 - character(len=256) :: solo_mosaic_file, grid_file - real, allocatable :: tmpx(:,:), tmpy(:,:) - logical :: open_solo_mosaic - type(FmsNetcdfFile_t) :: mosaicfileobj, tilefileobj - integer :: start(2), nread(2) - - 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, & - "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ") - - call mpp_get_data_domain(domain, isd, ied, jsd, jed) - call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - - ! get the grid file to read - - if(variable_exists(fileobj, trim(mod_name)//'_mosaic_file' )) then - call read_data(fileobj, trim(mod_name)//'_mosaic_file', solo_mosaic_file) - - solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file) - if(.not. open_file(mosaicfileobj, solo_mosaic_file, 'read')) then - call mpp_error(FATAL, 'data_override_mod(get_grid_version_2: Error in opening solo mosaic file '// & - & trim(solo_mosaic_file)) - endif - open_solo_mosaic=.true. - else - mosaicfileobj = fileobj - open_solo_mosaic = .false. - end if - - call get_mosaic_tile_grid(grid_file, mosaicfileobj, domain) - - if(.not. open_file(tilefileobj, grid_file, 'read')) then - call mpp_error(FATAL, 'data_override_mod(get_grid_version_2: Error in opening tile file '//trim(grid_file)) - endif - - call get_variable_size(tilefileobj, 'area', siz) - nlon_super = siz(1); nlat_super = siz(2) - if( mod(nlon_super,2) .NE. 0) call mpp_error(FATAL, & - 'data_override_mod: '//trim(mod_name)//' supergrid longitude size can not be divided by 2') - if( mod(nlat_super,2) .NE. 0) call mpp_error(FATAL, & - 'data_override_mod: '//trim(mod_name)//' supergrid latitude size can not be divided by 2') - nlon = nlon_super/2; - nlat = nlat_super/2; - call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat) - isc2 = 2*isc-1; iec2 = 2*iec+1 - jsc2 = 2*jsc-1; jec2 = 2*jec+1 - - start(1) = isc2; nread(1) = iec2-isc2+1 - start(2) = jsc2; nread(2) = jec2-jsc2+1 - - allocate(tmpx(isc2:iec2, jsc2:jec2), tmpy(isc2:iec2, jsc2:jec2) ) - - call read_data( tilefileobj, 'x', tmpx, corner=start,edge_lengths=nread) - 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 - 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 - 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 - endif - - ! convert to radian - lon = lon * deg_to_radian - lat = lat * deg_to_radian - - deallocate(tmpx, tmpy) - min_lon = minval(lon) - max_lon = maxval(lon) - call mpp_min(min_lon) - call mpp_max(max_lon) - - call close_file(tilefileobj) - if(open_solo_mosaic) call close_file(mosaicfileobj) - -end subroutine get_grid_version_2 +#include "get_grid_version_r4.fh" +#include "get_grid_version_r8.fh" end module get_grid_version_mod !> @} diff --git a/data_override/include/data_override.inc b/data_override/include/data_override_impl.inc similarity index 76% rename from data_override/include/data_override.inc rename to data_override/include/data_override_impl.inc index e95d5943d9..3b78cac877 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override_impl.inc @@ -1,188 +1,112 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup data_override_mod data_override_mod -!> @ingroup data_override -!! @brief Routines to get data in a file whose path is described in a user-provided data_table -!! and do spatial and temporal interpolation if necessary to convert data to model's grid and time. -!! @author Z. Liang, M.J. Harrison, M. Winton -!! -!! Before using @ref data_override a data_table must be created with the following entries: -!! gridname, fieldname_code, fieldname_file, file_name, ongrid, factor. -!! -!! More explainations about data_table entries can be found in the source code (defining data_type) -!! -!! If user wants to override fieldname_code with a const, set fieldname_file in data_table = "" -!! and factor = const -!! -!! If user wants to override fieldname_code with data from a file, set fieldname_file = name in -!! the netCDF data file, factor then will be for unit conversion (=1 if no conversion required) -!! -!! A field can be overriden globally (by default) or users can specify one or two regions in which -!! data_override will take place, field values outside the region will not be affected. - -module data_override_mod -use yaml_parser_mod -use constants_mod, only: PI -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(=) -use time_interp_external2_mod, only:time_interp_external_init, & - time_interp_external, & - init_external_field, & - get_external_field_size, & - set_override_region, & - reset_src_data_region, & - NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & - get_external_fileobj -use fms_mod, only: write_version_number, lowercase, check_nml_error -use axis_utils2_mod, only : nearest_index, axis_edges -use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.) -use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain -use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG -use time_manager_mod, only: time_type -use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & - read_data, fms2_io_init, variable_exists, & - get_mosaic_tile_file +module DATA_OVERRIDE_IMPL_ + use platform_mod, only: r4_kind, r8_kind + 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(=) + use time_interp_external2_mod, only: time_interp_external_init, & + time_interp_external, & + init_external_field, & + get_external_field_size, & + set_override_region, & + reset_src_data_region, & + NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & + get_external_fileobj + use fms_mod, only: write_version_number, lowercase, check_nml_error + use axis_utils2_mod, only : nearest_index, axis_edges + use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.) + use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain + use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG + use time_manager_mod, only: time_type + use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & + read_data, fms2_io_init, variable_exists, & + get_mosaic_tile_file use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 -implicit none -private + implicit none + private ! Include variable "version" to be written to log file. #include -!> Private type for holding field and grid information from a data table -!> @ingroup data_override_mod -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=128) :: interpol_method !< interpolation method (default "bilinear") - real :: factor !< For unit conversion, default=1, see OVERVIEW above - real :: lon_start, lon_end, lat_start, lat_end - integer :: region_type -end type data_type - -!> Private type for holding various data fields for performing data overrides -!> @ingroup data_override_mod -type override_type - character(len=3) :: gridname - character(len=128) :: fieldname - integer :: t_index !< index for time interp - type(horiz_interp_type), allocatable :: horz_interp(:) !< index for horizontal spatial interp - integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename - integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain - integer :: numthreads - real, allocatable :: lon_in(:) - real, allocatable :: lat_in(:) - logical, allocatable :: need_compute(:) - integer :: numwindows - integer :: window_size(2) - integer :: is_src, ie_src, js_src, je_src -end type override_type - -!> Interface for inserting and interpolating data into a file -!! for a model's grid and time. Data path must be described in -!! a user-provided data_table, see @ref data_override_mod "module description" -!! for more information. -!> @ingroup data_override_mod -interface data_override - module procedure data_override_0d - module procedure data_override_2d - module procedure data_override_3d -end interface - -!> Version of @ref data_override for unstructured grids -!> @ingroup data_override_mod -interface data_override_UG - module procedure data_override_UG_1d - module procedure data_override_UG_2d -end interface - -!> @addtogroup data_override_mod -!> @{ - integer, parameter :: max_table=100, max_array=100 - real, parameter :: deg_to_radian=PI/180. - integer :: table_size !< actual size of data table - logical :: module_is_initialized = .FALSE. - -type(domain2D),save :: ocn_domain,atm_domain,lnd_domain, ice_domain -type(domainUG),save :: lnd_domainUG - -real, dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn -real, dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm -real, dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice -real, dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd -real :: min_glo_lon_ocn, max_glo_lon_ocn -real :: min_glo_lon_atm, max_glo_lon_atm -real :: min_glo_lon_lnd, max_glo_lon_lnd -real :: min_glo_lon_ice, max_glo_lon_ice -integer:: num_fields = 0 !< number of fields in override_array already processed + !> Private type for holding field and grid information from a data table + !> @ingroup data_override_mod + 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=128) :: interpol_method !< interpolation method (default "bilinear") + real(DATA_OVERRIDE_KIND_) :: factor !< For unit conversion, default=1, see OVERVIEW above + real(DATA_OVERRIDE_KIND_) :: lon_start, lon_end, lat_start, lat_end + integer :: region_type + end type data_type + + !> Private type for holding various data fields for performing data overrides + !> @ingroup data_override_mod + type override_type + character(len=3) :: gridname + character(len=128) :: fieldname + integer :: t_index !< index for time interp + type(horiz_interp_type), allocatable :: horz_interp(:) !< index for horizontal spatial interp + integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename + integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain + integer :: numthreads + real(DATA_OVERRIDE_KIND_), allocatable :: lon_in(:) + real(DATA_OVERRIDE_KIND_), allocatable :: lat_in(:) + logical, allocatable :: need_compute(:) + integer :: numwindows + integer :: window_size(2) + integer :: is_src, ie_src, js_src, je_src + end type override_type + + integer, parameter :: lkind = DATA_OVERRIDE_KIND_ + integer, parameter :: max_table=100, max_array=100 + + integer :: table_size !< actual size of data table + logical :: module_is_initialized = .FALSE. + + type(domain2D) :: ocn_domain,atm_domain,lnd_domain, ice_domain + type(domainUG) :: lnd_domainUG + + real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn + real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm + real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice + real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd + real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ocn, max_glo_lon_ocn + real(DATA_OVERRIDE_KIND_) :: min_glo_lon_atm, max_glo_lon_atm + real(DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd + real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice + integer :: num_fields = 0 !< number of fields in override_array already processed + #ifdef use_yaml -type(data_type), dimension(:), allocatable :: data_table !< user-provided data table + type(data_type), dimension(:), allocatable :: data_table !< user-provided data table #else -type(data_type), dimension(max_table) :: data_table !< user-provided data table + type(data_type), dimension(max_table) :: data_table !< user-provided data table #endif -type(data_type) :: default_table -type(override_type), dimension(max_array), save :: override_array !< to store processed fields -type(override_type), save :: default_array -logical :: atm_on, ocn_on, lnd_on, ice_on -logical :: lndUG_on -logical :: debug_data_override -logical :: grid_center_bug = .false. -logical :: reproduce_null_char_bug = .false. !> Flag indicating - !! to reproduce the mpp_io bug where lat/lon_bnd were - !! not read correctly if null characters are present in - !! the netcdf file - -namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug - + type(data_type) :: default_table + type(override_type), dimension(max_array) :: override_array !< to store processed fields + type(override_type) :: default_array + logical :: debug_data_override + logical :: grid_center_bug = .false. + logical :: reproduce_null_char_bug = .false. !> Flag indicating + !! to reproduce the mpp_io bug where lat/lon_bnd were + !! not read correctly if null characters are present in + !! the netcdf file -public :: data_override_init, data_override, data_override_unset_domains -public :: data_override_UG + namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug -contains -function count_ne_1(in_1, in_2, in_3) - logical, intent(in) :: in_1, in_2, in_3 - logical :: count_ne_1 + public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & + & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_IMPL_, & + & DATA_OVERRIDE_2D_IMPL_, DATA_OVERRIDE_3D_IMPL_, DATA_OVERRIDE_UG_1D_IMPL_, & + & DATA_OVERRIDE_UG_2D_IMPL_ - count_ne_1 = .not.(in_1.NEQV.in_2.NEQV.in_3) .OR. (in_1.AND.in_2.AND.in_3) -end function count_ne_1 + contains -!> @brief Assign default values for default_table, get domain of component models, -!! get global grids of component models. -!! Users should call data_override_init before calling data_override -!! -!! This subroutine should be called in coupler_init after -!! (ocean/atmos/land/ice)_model_init have been called. -!! -!! data_override_init can be called more than once, in one call the user can pass -!! up to 4 domains of component models, at least one domain must be present in -!! any call -!! -!! Data_table is initialized here with default values. Users should provide "real" values -!! that will override the default values. Real values can be given using data_table, each -!! line of data_table contains one data_entry. Items of data_entry are comma separated. -subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) +subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) type (domain2d), intent(in), optional :: Atm_domain_in type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in type (domain2d), intent(in), optional :: Land_domain_in @@ -191,6 +115,7 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan character(len=128) :: grid_file = 'INPUT/grid_spec.nc' integer :: is,ie,js,je,use_get_grid_version integer :: i, unit, io_status, ierr + logical :: atm_on, ocn_on, lnd_on, ice_on, lndUG_on logical :: file_open type(FmsNetcdfFile_t) :: fileobj @@ -208,8 +133,6 @@ if (grid_center_bug) then "that is no longer supported. Please remove this namelist variable.") endif -! if(module_is_initialized) return - atm_on = PRESENT(Atm_domain_in) ocn_on = PRESENT(Ocean_domain_in) lnd_on = PRESENT(Land_domain_in) @@ -237,7 +160,7 @@ endif default_table%fieldname_code = 'none' default_table%fieldname_file = 'none' default_table%file_name = 'none' - default_table%factor = 1. + default_table%factor = 1._lkind default_table%interpol_method = 'bilinear' #ifdef use_yaml @@ -351,8 +274,14 @@ endif if(use_get_grid_version .EQ. 2) then call close_file(fileobj) end if +end subroutine DATA_OVERRIDE_INIT_IMPL_ + +function count_ne_1(in_1, in_2, in_3) + logical, intent(in) :: in_1, in_2, in_3 + logical :: count_ne_1 -end subroutine data_override_init + count_ne_1 = .not.(in_1.NEQV.in_2.NEQV.in_3) .OR. (in_1.AND.in_2.AND.in_3) +end function count_ne_1 #ifndef use_yaml subroutine read_table(data_table) @@ -455,10 +384,10 @@ subroutine read_table(data_table) else data_entry%interpol_method = 'bilinear' endif - data_entry%lon_start = 0.0 - data_entry%lon_end = -1.0 - data_entry%lat_start = 0.0 - data_entry%lat_end = -1.0 + data_entry%lon_start = 0.0_lkind + data_entry%lon_end = -1.0_lkind + data_entry%lat_start = 0.0_lkind + data_entry%lat_end = -1.0_lkind data_entry%region_type = NO_REGION else ! new format ntable_new=ntable_new+1 @@ -481,10 +410,10 @@ subroutine read_table(data_table) call mpp_error(FATAL, 'data_override_mod: invalid last entry in data_override_table, ' & //'its value should be "default", "bicubic", "bilinear" or "none" ') endif - data_entry%lon_start = 0.0 - data_entry%lon_end = -1.0 - data_entry%lat_start = 0.0 - data_entry%lat_end = -1.0 + data_entry%lon_start = 0.0_lkind + data_entry%lon_end = -1.0_lkind + data_entry%lat_start = 0.0_lkind + data_entry%lat_end = -1.0_lkind data_entry%region_type = NO_REGION endif data_table(ntable) = data_entry @@ -557,55 +486,29 @@ subroutine read_table_yaml(data_table) end subroutine read_table_yaml #endif -!> @brief Unset domains that had previously been set for use by data_override. -!! -!! This subroutine deallocates any data override domains that have been set. -subroutine data_override_unset_domains(unset_Atm, unset_Ocean, & - unset_Ice, unset_Land, must_be_set) - logical, intent(in), optional :: unset_Atm, unset_Ocean, unset_Ice, unset_Land - logical, intent(in), optional :: must_be_set - - logical :: fail_if_not_set - - fail_if_not_set = .true. ; if (present(must_be_set)) fail_if_not_set = must_be_set - - if (.not.module_is_initialized) call mpp_error(FATAL, & - "data_override_unset_domains called with an unititialized data_override module.") - - if (PRESENT(unset_Atm)) then ; if (unset_Atm) then - if (fail_if_not_set .and. .not.atm_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Atm_domain that had not been set.") - atm_domain = NULL_DOMAIN2D - atm_on = .false. - if (allocated(lon_local_atm)) deallocate(lon_local_atm) - if (allocated(lat_local_atm)) deallocate(lat_local_atm) - endif ; endif - if (PRESENT(unset_Ocean)) then ; if (unset_Ocean) then - if (fail_if_not_set .and. .not.ocn_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Ocn_domain that had not been set.") - ocn_domain = NULL_DOMAIN2D - ocn_on = .false. - if (allocated(lon_local_ocn)) deallocate(lon_local_ocn) - if (allocated(lat_local_ocn)) deallocate(lat_local_ocn) - endif ; endif - if (PRESENT(unset_Land)) then ; if (unset_Land) then - if (fail_if_not_set .and. .not.lnd_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on a Land_domain that had not been set.") - lnd_domain = NULL_DOMAIN2D - lnd_on = .false. - if (allocated(lon_local_lnd)) deallocate(lon_local_lnd) - if (allocated(lat_local_lnd)) deallocate(lat_local_lnd) - endif ; endif - if (PRESENT(unset_Ice)) then ; if (unset_Ice) then - if (fail_if_not_set .and. .not.ice_on) call mpp_error(FATAL, & - "data_override_unset_domains attempted to work on an Ice_domain that had not been set.") - ice_domain = NULL_DOMAIN2D - ice_on = .false. - if (allocated(lon_local_ice)) deallocate(lon_local_ice) - if (allocated(lat_local_ice)) deallocate(lat_local_ice) - endif ; endif - -end subroutine data_override_unset_domains +subroutine DATA_OVERRIDE_UNSET_ATM_ + atm_domain = NULL_DOMAIN2D + if (allocated(lon_local_atm)) deallocate(lon_local_atm) + if (allocated(lat_local_atm)) deallocate(lat_local_atm) +end subroutine + +subroutine DATA_OVERRIDE_UNSET_OCN_ + ocn_domain = NULL_DOMAIN2D + if (allocated(lon_local_ocn)) deallocate(lon_local_ocn) + if (allocated(lat_local_ocn)) deallocate(lat_local_ocn) +end subroutine + +subroutine DATA_OVERRIDE_UNSET_LND_ + lnd_domain = NULL_DOMAIN2D + if (allocated(lon_local_lnd)) deallocate(lon_local_lnd) + if (allocated(lat_local_lnd)) deallocate(lat_local_lnd) +end subroutine + +subroutine DATA_OVERRIDE_UNSET_ICE_ + ice_domain = NULL_DOMAIN2D + if (allocated(lon_local_ice)) deallocate(lon_local_ice) + if (allocated(lat_local_ice)) deallocate(lat_local_ice) +end subroutine !> @brief Given a gridname, this routine returns the working domain associated with this gridname subroutine get_domain(gridname, domain, comp_domain) @@ -652,16 +555,102 @@ subroutine get_domainUG(gridname, UGdomain, comp_domain) end subroutine get_domainUG !=============================================================================================== +!> @brief Routine to perform data override for scalar fields +subroutine DATA_OVERRIDE_0D_IMPL_(gridname,fieldname_code,data,time,override,data_index) + character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) + character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be + !! different from the name in NetCDF data file) + logical, intent(out), optional :: override !< true if the field has been overriden succesfully + type(time_type), intent(in) :: time !< (target) model time + real(DATA_OVERRIDE_KIND_), intent(out) :: data !< output data array returned by this call + integer, intent(in), optional :: data_index + + character(len=512) :: filename !< file containing source data + character(len=128) :: fieldname !< fieldname used in the data file + integer :: index1 !< field index in data_table + integer :: id_time !< index for time interp in override array + integer :: curr_position !< position of the field currently processed in override_array + integer :: i + real(DATA_OVERRIDE_KIND_) :: factor + + if(.not.module_is_initialized) & + call mpp_error(FATAL,'Error: need to call data_override_init first') + +!1 Look for the data file in data_table + if(PRESENT(override)) override = .false. + if (present(data_index)) then + index1 = data_index + else + index1 = -1 + do i = 1, table_size + if( trim(gridname) /= trim(data_table(i)%gridname)) cycle + if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle + index1 = i ! field found + exit + enddo + if(index1 .eq. -1) then + if(debug_data_override) & + call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code)) + return ! NO override was performed + endif + endif + + fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file + factor = data_table(index1)%factor + + if(fieldname == "") then + data = factor + if(PRESENT(override)) override = .true. + return + else + filename = data_table(index1)%file_name + if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table') + endif + +!3 Check if fieldname has been previously processed +!$OMP SINGLE + curr_position = -1 + if(num_fields > 0 ) then + do i = 1, num_fields + if(trim(override_array(i)%gridname) /= trim(gridname)) cycle + if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle + curr_position = i + exit + enddo + endif + + if(curr_position < 0) then ! the field has not been processed previously + num_fields = num_fields + 1 + curr_position = num_fields + ! record fieldname, gridname in override_array + override_array(curr_position)%fieldname = fieldname_code + override_array(curr_position)%gridname = gridname + id_time = init_external_field(filename,fieldname,verbose=.false.) + if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') + override_array(curr_position)%t_index = id_time + else !curr_position >0 + !9 Get id_time previously stored in override_array + id_time = override_array(curr_position)%t_index + endif !if curr_position < 0 + + !10 do time interp to get data in compute_domain + call time_interp_external(id_time, time, data, verbose=.false.) + data = data*factor +!$OMP END SINGLE + + if(PRESENT(override)) override = .true. + +end subroutine DATA_OVERRIDE_0D_IMPL_ + !> @brief This routine performs data override for 2D fields; for usage, see data_override_3d. -subroutine data_override_2d(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< model time - real, dimension(:,:), intent(inout) :: data_2D !< data returned by this call + real(DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data_2D !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in -! real, dimension(size(data_2D,1),size(data_2D,2),1) :: data_3D - real, dimension(:,:,:), allocatable :: data_3D + real(DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_3D integer :: index1 integer :: i @@ -678,21 +667,21 @@ subroutine data_override_2d(gridname,fieldname,data_2D,time,override, is_in, ie_ allocate(data_3D(size(data_2D,1),size(data_2D,2),1)) data_3D(:,:,1) = data_2D - call data_override_3d(gridname,fieldname,data_3D,time,override,data_index=index1,& + call DATA_OVERRIDE_3D_IMPL_(gridname,fieldname,data_3D,time,override,data_index=index1,& is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in) data_2D(:,:) = data_3D(:,:,1) deallocate(data_3D) -end subroutine data_override_2d +end subroutine DATA_OVERRIDE_2D_IMPL_ !> @brief This routine performs data override for 3D fields -subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_3D_IMPL_(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname_code !< field name as used in the model logical, optional, intent(out) :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time integer, optional, intent(in) :: data_index - real, dimension(:,:,:), intent(inout) :: data !< data returned by this call + real(DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: data !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in logical, dimension(:,:,:), allocatable :: mask_out @@ -705,15 +694,15 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde integer :: id_time !< index for time interp in override array integer :: axis_sizes(4) character(len=32) :: axis_names(4) - real, dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells - real, dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells - real, dimension(:), allocatable :: lon_tmp, lat_tmp + real(DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells + real(DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells + real(DATA_OVERRIDE_KIND_), dimension(:), allocatable :: lon_tmp, lat_tmp logical :: data_file_is_2D = .false. !< data in netCDF file is 2D logical :: ongrid, use_comp_domain type(domain2D) :: domain integer :: curr_position !< position of the field currently processed in override_array - real :: factor + real(DATA_OVERRIDE_KIND_) :: factor integer, dimension(4) :: comp_domain = 0 !< istart,iend,jstart,jend for compute domain integer :: nxd, nyd, nxc, nyc, nwindows integer :: nwindows_x, ipos, jpos, window_size(2) @@ -721,7 +710,7 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde integer :: isw, iew, jsw, jew integer :: omp_get_num_threads, window_id logical :: need_compute - real :: lat_min, lat_max + real(DATA_OVERRIDE_KIND_) :: lat_min, lat_max integer :: is_src, ie_src, js_src, je_src logical :: exists type(FmsNetcdfFile_t) :: fileobj @@ -871,8 +860,8 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde call mpp_error(FATAL,'data_override: file '//trim(filename)//' is not opened in time_interp_external') end if ! convert lon_in and lat_in from deg to radian - override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * deg_to_radian - override_array(curr_position)%lat_in = override_array(curr_position)%lat_in * deg_to_radian + override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * DEG_TO_RAD + override_array(curr_position)%lat_in = override_array(curr_position)%lat_in * DEG_TO_RAD !--- find the region of the source grid that cover the local model grid. !--- currently we only find the index range for j-direction because @@ -1130,104 +1119,17 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde if(PRESENT(override)) override = .true. -end subroutine data_override_3d - -!> @brief Routine to perform data override for scalar fields -subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_index) - character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) - character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be - !! different from the name in NetCDF data file) - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - type(time_type), intent(in) :: time !< (target) model time - real, intent(out) :: data !< output data array returned by this call - integer, intent(in), optional :: data_index - - character(len=512) :: filename !< file containing source data - character(len=128) :: fieldname !< fieldname used in the data file - integer :: index1 !< field index in data_table - integer :: id_time !< index for time interp in override array - integer :: curr_position !< position of the field currently processed in override_array - integer :: i - real :: factor - - if(.not.module_is_initialized) & - call mpp_error(FATAL,'Error: need to call data_override_init first') - -!1 Look for the data file in data_table - if(PRESENT(override)) override = .false. - if (present(data_index)) then - index1 = data_index - else - index1 = -1 - do i = 1, table_size - if( trim(gridname) /= trim(data_table(i)%gridname)) cycle - if( trim(fieldname_code) /= trim(data_table(i)%fieldname_code)) cycle - index1 = i ! field found - exit - enddo - if(index1 .eq. -1) then - if(debug_data_override) & - call mpp_error(WARNING,'this field is NOT found in data_table: '//trim(fieldname_code)) - return ! NO override was performed - endif - endif +end subroutine DATA_OVERRIDE_3D_IMPL_ - fieldname = data_table(index1)%fieldname_file ! fieldname in netCDF data file - factor = data_table(index1)%factor - - if(fieldname == "") then - data = factor - if(PRESENT(override)) override = .true. - return - else - filename = data_table(index1)%file_name - if (filename == "") call mpp_error(FATAL,'data_override: filename not given in data_table') - endif - -!3 Check if fieldname has been previously processed -!$OMP SINGLE - curr_position = -1 - if(num_fields > 0 ) then - do i = 1, num_fields - if(trim(override_array(i)%gridname) /= trim(gridname)) cycle - if(trim(override_array(i)%fieldname) /= trim(fieldname_code)) cycle - curr_position = i - exit - enddo - endif - - if(curr_position < 0) then ! the field has not been processed previously - num_fields = num_fields + 1 - curr_position = num_fields - ! record fieldname, gridname in override_array - override_array(curr_position)%fieldname = fieldname_code - override_array(curr_position)%gridname = gridname - id_time = init_external_field(filename,fieldname,verbose=.false.) - if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1') - override_array(curr_position)%t_index = id_time - else !curr_position >0 - !9 Get id_time previously stored in override_array - id_time = override_array(curr_position)%t_index - endif !if curr_position < 0 - - !10 do time interp to get data in compute_domain - call time_interp_external(id_time, time, data, verbose=.false.) - data = data*factor -!$OMP END SINGLE - - if(PRESENT(override)) override = .true. - -end subroutine data_override_0d - -!> @brief Data override for 2D unstructured grids -subroutine data_override_UG_1d(gridname,fieldname,data,time,override) +!> @brief Data override for 1D unstructured grids +subroutine DATA_OVERRIDE_UG_1D_IMPL_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real, dimension(:), intent(inout) :: data !< data returned by this call + real(DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars - real, dimension(:,:), allocatable :: data_SG + real(DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_SG type(domainUG) :: UG_domain integer :: index1 integer :: i @@ -1247,24 +1149,24 @@ subroutine data_override_UG_1d(gridname,fieldname,data,time,override) call get_domainUG(gridname,UG_domain,comp_domain) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4))) - call data_override_2d(gridname,fieldname,data_SG,time,override) + call DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) deallocate(data_SG) -end subroutine data_override_UG_1d +end subroutine DATA_OVERRIDE_UG_1D_IMPL_ !> @brief Data override for 2D unstructured grids -subroutine data_override_UG_2d(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_2D_IMPL_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real, dimension(:,:), intent(inout) :: data !< data returned by this call + real(DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars - real, dimension(:,:,:), allocatable :: data_SG - real, dimension(:,:), allocatable :: data_UG + real(DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_SG + real(DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_UG type(domainUG) :: UG_domain integer :: index1 integer :: i, nlevel, nlevel_max @@ -1288,16 +1190,14 @@ subroutine data_override_UG_2d(gridname,fieldname,data,time,override) call get_domainUG(gridname,UG_domain,comp_domain) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),nlevel_max)) allocate(data_UG(size(data,1), nlevel_max)) - data_SG = 0.0 - call data_override_3d(gridname,fieldname,data_SG,time,override) + data_SG = 0._lkind + call DATA_OVERRIDE_3D_IMPL_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:,:), data_UG(:,:)) data(:,1:nlevel) = data_UG(:,1:nlevel) deallocate(data_SG, data_UG) -end subroutine data_override_UG_2d +end subroutine DATA_OVERRIDE_UG_2D_IMPL_ -end module data_override_mod -!> @} -! close documentation grouping +end module diff --git a/data_override/include/data_override_impl_r4.fh b/data_override/include/data_override_impl_r4.fh new file mode 100644 index 0000000000..ed2b995a79 --- /dev/null +++ b/data_override/include/data_override_impl_r4.fh @@ -0,0 +1,50 @@ +#undef DATA_OVERRIDE_KIND_ +#define DATA_OVERRIDE_KIND_ r4_kind + +#undef DATA_OVERRIDE_IMPL_ +#define DATA_OVERRIDE_IMPL_ data_override_r4 + +#undef DATA_OVERRIDE_INIT_IMPL_ +#define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r4 + +#undef DATA_OVERRIDE_UNSET_ATM_ +#define DATA_OVERRIDE_UNSET_ATM_ data_override_unset_atm_r4 + +#undef DATA_OVERRIDE_UNSET_OCN_ +#define DATA_OVERRIDE_UNSET_OCN_ data_override_unset_ocn_r4 + +#undef DATA_OVERRIDE_UNSET_LND_ +#define DATA_OVERRIDE_UNSET_LND_ data_override_unset_lnd_r4 + +#undef DATA_OVERRIDE_UNSET_ICE_ +#define DATA_OVERRIDE_UNSET_ICE_ data_override_unset_ice_r4 + +#undef DATA_OVERRIDE_0D_IMPL_ +#define DATA_OVERRIDE_0D_IMPL_ data_override_0d_r4 + +#undef DATA_OVERRIDE_2D_IMPL_ +#define DATA_OVERRIDE_2D_IMPL_ data_override_2d_r4 + +#undef DATA_OVERRIDE_3D_IMPL_ +#define DATA_OVERRIDE_3D_IMPL_ data_override_3d_r4 + +#undef DATA_OVERRIDE_UG_1D_IMPL_ +#define DATA_OVERRIDE_UG_1D_IMPL_ data_override_ug_1d_r4 + +#undef DATA_OVERRIDE_UG_2D_IMPL_ +#define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r4 + +#include "data_override_impl.inc" + +#undef DATA_OVERRIDE_KIND_ +#undef DATA_OVERRIDE_IMPL_ +#undef DATA_OVERRIDE_INIT_IMPL_ +#undef DATA_OVERRIDE_UNSET_ATM_ +#undef DATA_OVERRIDE_UNSET_OCN_ +#undef DATA_OVERRIDE_UNSET_LND_ +#undef DATA_OVERRIDE_UNSET_ICE_ +#undef DATA_OVERRIDE_0D_IMPL_ +#undef DATA_OVERRIDE_2D_IMPL_ +#undef DATA_OVERRIDE_3D_IMPL_ +#undef DATA_OVERRIDE_UG_1D_IMPL_ +#undef DATA_OVERRIDE_UG_2D_IMPL_ diff --git a/data_override/include/data_override_impl_r8.fh b/data_override/include/data_override_impl_r8.fh new file mode 100644 index 0000000000..fd711d6764 --- /dev/null +++ b/data_override/include/data_override_impl_r8.fh @@ -0,0 +1,50 @@ +#undef DATA_OVERRIDE_KIND_ +#define DATA_OVERRIDE_KIND_ r8_kind + +#undef DATA_OVERRIDE_IMPL_ +#define DATA_OVERRIDE_IMPL_ data_override_r8 + +#undef DATA_OVERRIDE_INIT_IMPL_ +#define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r8 + +#undef DATA_OVERRIDE_UNSET_ATM_ +#define DATA_OVERRIDE_UNSET_ATM_ data_override_unset_atm_r8 + +#undef DATA_OVERRIDE_UNSET_OCN_ +#define DATA_OVERRIDE_UNSET_OCN_ data_override_unset_ocn_r8 + +#undef DATA_OVERRIDE_UNSET_LND_ +#define DATA_OVERRIDE_UNSET_LND_ data_override_unset_lnd_r8 + +#undef DATA_OVERRIDE_UNSET_ICE_ +#define DATA_OVERRIDE_UNSET_ICE_ data_override_unset_ice_r8 + +#undef DATA_OVERRIDE_0D_IMPL_ +#define DATA_OVERRIDE_0D_IMPL_ data_override_0d_r8 + +#undef DATA_OVERRIDE_2D_IMPL_ +#define DATA_OVERRIDE_2D_IMPL_ data_override_2d_r8 + +#undef DATA_OVERRIDE_3D_IMPL_ +#define DATA_OVERRIDE_3D_IMPL_ data_override_3d_r8 + +#undef DATA_OVERRIDE_UG_1D_IMPL_ +#define DATA_OVERRIDE_UG_1D_IMPL_ data_override_ug_1d_r8 + +#undef DATA_OVERRIDE_UG_2D_IMPL_ +#define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r8 + +#include "data_override_impl.inc" + +#undef DATA_OVERRIDE_KIND_ +#undef DATA_OVERRIDE_IMPL_ +#undef DATA_OVERRIDE_INIT_IMPL_ +#undef DATA_OVERRIDE_UNSET_ATM_ +#undef DATA_OVERRIDE_UNSET_OCN_ +#undef DATA_OVERRIDE_UNSET_LND_ +#undef DATA_OVERRIDE_UNSET_ICE_ +#undef DATA_OVERRIDE_0D_IMPL_ +#undef DATA_OVERRIDE_2D_IMPL_ +#undef DATA_OVERRIDE_3D_IMPL_ +#undef DATA_OVERRIDE_UG_1D_IMPL_ +#undef DATA_OVERRIDE_UG_2D_IMPL_ diff --git a/data_override/include/get_grid_version.inc b/data_override/include/get_grid_version.inc index 451c570d43..e2d7a6bd15 100644 --- a/data_override/include/get_grid_version.inc +++ b/data_override/include/get_grid_version.inc @@ -16,71 +16,30 @@ !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** -!> @defgroup get_grid_version_mod get_grid_version_mod -!> @ingroup data_override -!> @brief get_grid implementations and helper routines for @ref data_override_mod - -!> @addtogroup get_grid_version_mod -!> @{ -module get_grid_version_mod -use constants_mod, only: PI -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 -use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, open_file, close_file, & - variable_exists, read_data, get_variable_size, get_variable_num_dimensions -use mosaic2_mod, only : get_mosaic_tile_grid - -implicit none - -real, parameter :: deg_to_radian=PI/180. -contains - -!> Get lon and lat of three model (target) grids from grid_spec.nc -subroutine check_grid_sizes(domain_name, Domain, nlon, nlat) -character(len=12), intent(in) :: domain_name -type (domain2d), intent(in) :: Domain -integer, intent(in) :: nlon, nlat - -character(len=184) :: error_message -integer :: xsize, ysize - -call mpp_get_global_domain(Domain, xsize=xsize, ysize=ysize) -if(nlon .NE. xsize .OR. nlat .NE. ysize) then - error_message = 'Error in data_override_init. Size of grid as specified by '// & - ' does not conform to that specified by grid_spec.nc.'// & - ' From : by From grid_spec.nc: by ' - error_message( 59: 70) = domain_name - error_message(130:141) = domain_name - write(error_message(143:146),'(i4)') xsize - write(error_message(150:153),'(i4)') ysize - write(error_message(174:177),'(i4)') nlon - write(error_message(181:184),'(i4)') nlat - call mpp_error(FATAL,error_message) -endif -end subroutine check_grid_sizes !> Get global lon and lat of three model (target) grids, with a given file name -subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) - character(len=*), intent(in) :: grid_file !< name of grid file - character(len=*), intent(in) :: mod_name !< module name - type(domain2d), intent(in) :: domain !< 2D domain - integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isc:,jsc:), intent(out) :: lon, lat - real, intent(out) :: min_lon, max_lon - - integer :: i, j, siz(4) - integer :: nlon, nlat !< size of global lon and lat - real, dimension(:,:,:), allocatable :: lon_vert, lat_vert !< of OCN grid vertices - real, dimension(:), allocatable :: glon, glat !< lon and lat of 1-D grid of atm/lnd - logical :: is_new_grid - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg - character(len=3) :: xname, yname - integer :: start(2), nread(2) - type(FmsNetcdfDomainFile_t) :: fileobj - integer :: ndims !< Number of dimensions +subroutine GET_GRID_VERSION_1_(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) + integer, parameter :: lkind = GET_GRID_VERSION_KIND_ + + character(len=*), intent(in) :: grid_file !< name of grid file + character(len=*), intent(in) :: mod_name !< module name + type(domain2d), intent(in) :: domain !< 2D domain + integer, intent(in) :: isc, iec, jsc, jec + real(lkind), dimension(isc:,jsc:), intent(out) :: lon, lat + real(lkind), intent(out) :: min_lon, max_lon + + integer :: i, j, siz(4) + integer :: nlon, nlat !< size of global lon and lat + real(lkind), dimension(:,:,:), allocatable :: lon_vert, lat_vert !< of OCN grid vertices + real(lkind), dimension(:), allocatable :: glon, glat !< lon and lat of 1-D grid of atm/lnd + logical :: is_new_grid + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: isg, ieg, jsg, jeg + character(len=3) :: xname, yname + integer :: start(2), nread(2) + type(FmsNetcdfDomainFile_t) :: fileobj + integer :: ndims !< Number of dimensions if(.not. open_file(fileobj, grid_file, 'read', domain )) then call mpp_error(FATAL, 'data_override_mod(get_grid_version_1): Error in opening file '//trim(grid_file)) @@ -111,8 +70,8 @@ subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, l call read_data(fileobj, 'y_vert_T', lat_vert) !2 Global lon and lat of ocean grid cell centers are determined from adjacent vertices - lon(:,:) = (lon_vert(:,:,1) + lon_vert(:,:,2) + lon_vert(:,:,3) + lon_vert(:,:,4))*0.25 - lat(:,:) = (lat_vert(:,:,1) + lat_vert(:,:,2) + lat_vert(:,:,3) + lat_vert(:,:,4))*0.25 + lon(:,:) = (lon_vert(:,:,1) + lon_vert(:,:,2) + lon_vert(:,:,3) + lon_vert(:,:,4))*0.25_lkind + lat(:,:) = (lat_vert(:,:,1) + lat_vert(:,:,2) + lat_vert(:,:,3) + lat_vert(:,:,4))*0.25_lkind else ndims = get_variable_num_dimensions(fileobj, 'geolon_vert_t') @@ -132,9 +91,9 @@ subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, l do j = jsc, jec do i = isc, iec lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1) + & - lon_vert(i+1,j+1,1) + lon_vert(i,j+1,1))*0.25 + lon_vert(i+1,j+1,1) + lon_vert(i,j+1,1))*0.25_lkind lat(i,j) = (lat_vert(i,j,1) + lat_vert(i+1,j,1) + & - lat_vert(i+1,j+1,1) + lat_vert(i,j+1,1))*0.25 + lat_vert(i+1,j+1,1) + lat_vert(i,j+1,1))*0.25_lkind enddo enddo endif @@ -174,37 +133,37 @@ subroutine get_grid_version_1(grid_file, mod_name, domain, isc, iec, jsc, jec, l call close_file(fileobj) ! convert from degree to radian - lon = lon * deg_to_radian - lat = lat* deg_to_radian + lon = lon * real(DEG_TO_RAD, lkind) + lat = lat* real(DEG_TO_RAD, lkind) min_lon = minval(lon) max_lon = maxval(lon) call mpp_min(min_lon) call mpp_max(max_lon) - - -end subroutine get_grid_version_1 +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) - type(FmsNetcdfFile_t), intent(in) :: fileobj !< file object for grid file - character(len=*), intent(in) :: mod_name !< module name - type(domain2d), intent(in) :: domain !< 2D domain - integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isc:,jsc:), intent(out) :: lon, lat - real, intent(out) :: min_lon, max_lon - - integer :: i, j, siz(2) - integer :: nlon, nlat ! size of global grid - integer :: nlon_super, nlat_super ! size of global supergrid. - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg - integer :: isc2, iec2, jsc2, jec2 - character(len=256) :: solo_mosaic_file, grid_file - real, allocatable :: tmpx(:,:), tmpy(:,:) - logical :: open_solo_mosaic - type(FmsNetcdfFile_t) :: mosaicfileobj, tilefileobj - integer :: start(2), nread(2) +subroutine GET_GRID_VERSION_2_(fileobj, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) + integer, parameter :: lkind = GET_GRID_VERSION_KIND_ + + type(FmsNetcdfFile_t), intent(in) :: fileobj !< file object for grid file + character(len=*), intent(in) :: mod_name !< module name + type(domain2d), intent(in) :: domain !< 2D domain + integer, intent(in) :: isc, iec, jsc, jec + real(lkind), dimension(isc:,jsc:), intent(out) :: lon, lat + real(lkind), intent(out) :: min_lon, max_lon + + integer :: i, j, siz(2) + integer :: nlon, nlat ! size of global grid + integer :: nlon_super, nlat_super ! size of global supergrid. + integer :: isd, ied, jsd, jed + integer :: isg, ieg, jsg, jeg + integer :: isc2, iec2, jsc2, jec2 + character(len=256) :: solo_mosaic_file, grid_file + real(lkind), allocatable :: tmpx(:,:), tmpy(:,:) + logical :: open_solo_mosaic + type(FmsNetcdfFile_t) :: mosaicfileobj, tilefileobj + integer :: start(2), nread(2) 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, & @@ -259,8 +218,8 @@ subroutine get_grid_version_2(fileobj, mod_name, domain, isc, iec, jsc, jec, lon 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 - 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 + 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 else @@ -273,8 +232,8 @@ subroutine get_grid_version_2(fileobj, mod_name, domain, isc, iec, jsc, jec, lon endif ! convert to radian - lon = lon * deg_to_radian - lat = lat * deg_to_radian + lon = lon * real(DEG_TO_RAD, lkind) + lat = lat * real(DEG_TO_RAD, lkind) deallocate(tmpx, tmpy) min_lon = minval(lon) @@ -284,9 +243,4 @@ subroutine get_grid_version_2(fileobj, mod_name, domain, isc, iec, jsc, jec, lon call close_file(tilefileobj) if(open_solo_mosaic) call close_file(mosaicfileobj) - -end subroutine get_grid_version_2 - -end module get_grid_version_mod -!> @} -! close documentation grouping +end subroutine GET_GRID_VERSION_2_ diff --git a/data_override/include/get_grid_version_r4.fh b/data_override/include/get_grid_version_r4.fh new file mode 100644 index 0000000000..d581c55ff0 --- /dev/null +++ b/data_override/include/get_grid_version_r4.fh @@ -0,0 +1,14 @@ +#undef GET_GRID_VERSION_KIND_ +#define GET_GRID_VERSION_KIND_ r4_kind + +#undef GET_GRID_VERSION_1_ +#define GET_GRID_VERSION_1_ get_grid_version_1_r4 + +#undef GET_GRID_VERSION_2_ +#define GET_GRID_VERSION_2_ get_grid_version_2_r4 + +#include "get_grid_version.inc" + +#undef GET_GRID_VERSION_KIND_ +#undef GET_GRID_VERSION_1_ +#undef GET_GRID_VERSION_2_ diff --git a/data_override/include/get_grid_version_r8.fh b/data_override/include/get_grid_version_r8.fh new file mode 100644 index 0000000000..eb4115c64e --- /dev/null +++ b/data_override/include/get_grid_version_r8.fh @@ -0,0 +1,14 @@ +#undef GET_GRID_VERSION_KIND_ +#define GET_GRID_VERSION_KIND_ r8_kind + +#undef GET_GRID_VERSION_1_ +#define GET_GRID_VERSION_1_ get_grid_version_1_r8 + +#undef GET_GRID_VERSION_2_ +#define GET_GRID_VERSION_2_ get_grid_version_2_r8 + +#include "get_grid_version.inc" + +#undef GET_GRID_VERSION_KIND_ +#undef GET_GRID_VERSION_1_ +#undef GET_GRID_VERSION_2_ diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index df990995f0..f5c956c446 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -29,12 +29,32 @@ AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_get_grid_v1 test_data_override test_data_override_ongrid +check_PROGRAMS = \ + test_get_grid_v1_r4 \ + test_get_grid_v1_r8 \ + test_data_override_r4 \ + test_data_override_r8 \ + test_data_override_ongrid_r4 \ + test_data_override_ongrid_r8 # This is the source code for the test. -test_data_override_SOURCES = test_data_override.F90 -test_data_override_ongrid_SOURCES = test_data_override_ongrid.F90 -test_get_grid_v1_SOURCES = test_get_grid_v1.F90 +test_data_override_r4_SOURCES = test_data_override.F90 +test_data_override_r8_SOURCES = test_data_override.F90 + +test_data_override_ongrid_r4_SOURCES = test_data_override_ongrid.F90 +test_data_override_ongrid_r8_SOURCES = test_data_override_ongrid.F90 + +test_get_grid_v1_r4_SOURCES = test_get_grid_v1.F90 +test_get_grid_v1_r8_SOURCES = test_get_grid_v1.F90 + +test_data_override_r4_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r4_kind +test_data_override_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind + +test_data_override_ongrid_r4_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r4_kind +test_data_override_ongrid_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind + +test_get_grid_v1_r4_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r4_kind +test_get_grid_v1_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind if SKIP_PARSER_TESTS skipflag="skip" diff --git a/test_fms/data_override/test_data_override.F90 b/test_fms/data_override/test_data_override.F90 index 36f22b3143..b104755b4f 100644 --- a/test_fms/data_override/test_data_override.F90 +++ b/test_fms/data_override/test_data_override.F90 @@ -102,12 +102,12 @@ program test integer :: nx_dom, ny_dom, nx_win, ny_win type(domain2d) :: Domain integer :: nlon, nlat, siz(2) - real, allocatable, dimension(:) :: x, y - real, allocatable, dimension(:,:) :: lon, lat - real, allocatable, dimension(:,:) :: sst, ice + real(DO_TEST_KIND_), allocatable, dimension(:) :: x, y + real(DO_TEST_KIND_), allocatable, dimension(:,:) :: lon, lat + real(DO_TEST_KIND_), allocatable, dimension(:,:) :: sst, ice integer :: id_x, id_y, id_lon, id_lat, id_sst, id_ice integer :: i, j, is, ie, js, je, io, ierr, n - real :: rad_to_deg + real(DO_TEST_KIND_) :: rad_to_deg character(len=36) :: message type(time_type) :: Time logical :: used @@ -322,8 +322,8 @@ program test !==================================================================================================================== subroutine get_grid - real, allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo - real, allocatable, dimension(:,:) :: lon_global, lat_global + real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo + real(DO_TEST_KIND_), allocatable, dimension(:,:) :: lon_global, lat_global integer, dimension(2) :: siz character(len=128) :: message @@ -421,10 +421,10 @@ subroutine test_unstruct_grid( type, Time ) integer, allocatable, dimension(:) :: pe_start, pe_end, npts_tile, grid_index, ntiles_grid integer, allocatable, dimension(:,:) :: layout2D, global_indices - real, allocatable, dimension(:,:) :: x1, x2, g1, g2 - real, allocatable, dimension(:,:,:) :: a1, a2, gdata - real, allocatable, dimension(:,:) :: rmask - real, allocatable, dimension(:) :: frac_crit + real(DO_TEST_KIND_), allocatable, dimension(:,:) :: x1, x2, g1, g2 + real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: a1, a2, gdata + real(DO_TEST_KIND_), allocatable, dimension(:,:) :: rmask + real(DO_TEST_KIND_), allocatable, dimension(:) :: frac_crit logical, allocatable, dimension(:,:,:) :: lmask,msk integer, allocatable, dimension(:) :: isl, iel, jsl, jel character(len=3) :: text @@ -667,7 +667,7 @@ subroutine test_unstruct_grid( type, Time ) end subroutine test_unstruct_grid subroutine compare_checksums( a, b, string ) - real, intent(in), dimension(:,:,:) :: a, b + real(DO_TEST_KIND_), intent(in), dimension(:,:,:) :: a, b character(len=*), intent(in) :: string integer(i8_kind) :: sum1, sum2 integer :: i, j, k,pe @@ -712,7 +712,7 @@ end subroutine compare_checksums !########################################################################### subroutine compare_checksums_2D( a, b, string ) - real, intent(in), dimension(:,:) :: a, b + real(DO_TEST_KIND_), intent(in), dimension(:,:) :: a, b character(len=*), intent(in) :: string integer(i8_kind) :: sum1, sum2 integer :: i, j,pe diff --git a/test_fms/data_override/test_data_override2.sh b/test_fms/data_override/test_data_override2.sh index 94013f1ff6..33a7866f67 100755 --- a/test_fms/data_override/test_data_override2.sh +++ b/test_fms/data_override/test_data_override2.sh @@ -47,6 +47,7 @@ _EOF # Run the ongrid test case with 2 halos in x and y touch input.nml + cat <<_EOF > data_table.yaml data_table: - gridname : OCN @@ -60,19 +61,30 @@ _EOF printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0' | cat > data_table [ ! -d "INPUT" ] && mkdir -p "INPUT" setup_test_dir 2 -test_expect_success "data_override on grid with 2 halos in x and y" ' - mpirun -n 6 ./test_data_override_ongrid -' + +for KIND in r4 r8 +do + test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' + mpirun -n 6 ./test_data_override_ongrid_${KIND} + ' +done setup_test_dir 0 -test_expect_success "data_override on grid with no halos" ' - mpirun -n 6 ./test_data_override_ongrid -' + +for KIND in r4 r8 +do + test_expect_success "data_override on grid with no halos (${KIND})" ' + mpirun -n 6 ./test_data_override_ongrid_${KIND} + ' +done # Run the get_grid_v1 test: -test_expect_success "data_override get_grid_v1" ' - mpirun -n 1 ./test_get_grid_v1 -' +for KIND in r4 r8 +do + test_expect_success "data_override get_grid_v1 (${KIND})" ' + mpirun -n 1 ./test_get_grid_v1_${KIND} + ' +done # Run tests with input if enabled # skips if built with yaml parser(tests older behavior) @@ -89,6 +101,7 @@ test_data_override "test_data_override_mod", "sst", "sst", "test_data_override", "all", .false., "none", 2 "test_data_override_mod", "ice", "ice", "test_data_override", "all", .false., "none", 2 _EOF + cat <<_EOF > data_table "ICE", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .false., 300.0 "ICE", "sic_obs", "SIC", "INPUT/sst_ice_clim.nc", .false., 300.0 @@ -96,18 +109,26 @@ _EOF "LND", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .false., 300.0 _EOF - test_expect_success "data_override on cubic-grid with input" ' - mpirun -n 6 ./test_data_override - ' -cat <<_EOF > input.nml + for KIND in r4 r8 + do + test_expect_success "data_override on cubic-grid with input (${KIND})" ' + mpirun -n 6 ./test_data_override_${KIND} + ' + done + + cat <<_EOF > input.nml &test_data_override_nml test_num=2 / _EOF - test_expect_success "data_override on latlon-grid with input" ' - mpirun -n 6 ./test_data_override - ' + for KIND in r4 r8 + do + test_expect_success "data_override on latlon-grid with input (${KIND})" ' + mpirun -n 6 ./test_data_override_${KIND} + ' + done + rm -rf INPUT *.nc # remove any leftover files to reduce size fi diff --git a/test_fms/data_override/test_data_override_ongrid.F90 b/test_fms/data_override/test_data_override_ongrid.F90 index edfa1e447b..c976382814 100644 --- a/test_fms/data_override/test_data_override_ongrid.F90 +++ b/test_fms/data_override/test_data_override_ongrid.F90 @@ -22,24 +22,26 @@ program test_data_override_ongrid !> @brief This programs tests data_override ability to override data for an !! on grid case -use mpp_domains_mod, only: mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, & - mpp_domains_set_stack_size, mpp_get_compute_domain, domain2d -use mpp_mod, only: mpp_init, mpp_exit, mpp_pe, mpp_root_pe, mpp_error, FATAL, & - input_nml_file, mpp_sync -use data_override_mod, only: data_override_init, data_override -use fms2_io_mod, only: fms2_io_init -use time_manager_mod, only: set_calendar_type, time_type, set_date, NOLEAP -use netcdf, only: nf90_create, nf90_def_dim, nf90_def_var, nf90_enddef, nf90_put_var, & - nf90_close, nf90_put_att, nf90_clobber, nf90_64bit_offset, nf90_char, & - nf90_double, nf90_unlimited +use platform_mod, only: r4_kind, r8_kind +use mpp_domains_mod, only: mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, & + mpp_domains_set_stack_size, mpp_get_compute_domain, domain2d +use mpp_mod, only: mpp_init, mpp_exit, mpp_pe, mpp_root_pe, mpp_error, FATAL, & + input_nml_file, mpp_sync +use data_override_mod, only: data_override_init, data_override +use fms2_io_mod, only: fms2_io_init +use time_manager_mod, only: set_calendar_type, time_type, set_date, NOLEAP +use netcdf, only: nf90_create, nf90_def_dim, nf90_def_var, nf90_enddef, nf90_put_var, & + nf90_close, nf90_put_att, nf90_clobber, nf90_64bit_offset, nf90_char, & + nf90_double, nf90_unlimited implicit none +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 type(domain2d) :: Domain !< Domain with mask table -real, allocatable, dimension(:,:) :: runoff !< Data to be written +real(DO_TEST_KIND_), allocatable, dimension(:,:) :: runoff !< Data to be written integer :: is !< Starting x index integer :: ie !< Ending x index integer :: js !< Starting y index @@ -50,8 +52,8 @@ program test_data_override_ongrid integer :: err !< Error Code integer :: dim1d, dim2d, dim3d, dim4d !< Dimension ids integer :: varid, varid2, varid3, varid4 !< Variable ids -real, allocatable, dimension(:,:,:) :: runoff_in !< Data to be written to file -real :: expected_result !< Expected result from data_override +real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: runoff_in !< Data to be written to file +real(DO_TEST_KIND_) :: expected_result !< Expected result from data_override integer :: nhalox=2, nhaloy=2 integer :: io_status @@ -67,7 +69,7 @@ program test_data_override_ongrid if (mpp_pe() .eq. mpp_root_pe()) then allocate(runoff_in(1440, 1080, 10)) do i = 1, 10 - runoff_in(:,:,i) = real(i) + runoff_in(:,:,i) = real(i, DO_TEST_KIND_) enddo err = nf90_create('INPUT/grid_spec.nc', ior(nf90_clobber, nf90_64bit_offset), ncid) @@ -153,7 +155,7 @@ program test_data_override_ongrid call data_override('OCN','runoff',runoff, Time) !< Because you are getting the data when time=3, and this is an "ongrid" case, the expected result is just !! equal to the data at time=3, which is 3. -expected_result = real(3.) +expected_result = 3._lkind call compare_data(Domain, runoff, expected_result) !< Run it when time=4 @@ -162,7 +164,7 @@ program test_data_override_ongrid call data_override('OCN','runoff',runoff, Time) !< You are getting the data when time=4, the data at time=3 is 3. and at time=5 is 4., so the expected result !! is the average of the 2 (because this is is an "ongrid" case and there is no horizontal interpolation). -expected_result = (real(3.)+ real(4.))/2 +expected_result = (3._lkind + 4._lkind) / 2._lkind call compare_data(Domain, runoff, expected_result) deallocate(runoff) @@ -173,8 +175,8 @@ program test_data_override_ongrid subroutine compare_data(Domain, actual_result, expected_result) type(domain2d), intent(in) :: Domain !< Domain with mask table -real, intent(in) :: expected_result !< Expected result from data_override -real, dimension(:,:), intent(in) :: actual_result !< Result from data_override +real(DO_TEST_KIND_), intent(in) :: expected_result !< Expected result from data_override +real(DO_TEST_KIND_), dimension(:,:), intent(in) :: actual_result !< Result from data_override integer :: xsizec, ysizec !< Size of the compute domain integer :: xsized, ysized !< Size of the data domain diff --git a/test_fms/data_override/test_get_grid_v1.F90 b/test_fms/data_override/test_get_grid_v1.F90 index b39e06c601..fe4c1127e3 100644 --- a/test_fms/data_override/test_get_grid_v1.F90 +++ b/test_fms/data_override/test_get_grid_v1.F90 @@ -30,7 +30,8 @@ program test_get_grid_v1 use fms2_io_mod, only: fms2_io_init use platform_mod -use get_grid_version_mod, only : get_grid_version_1, deg_to_radian +use get_grid_version_mod, only : get_grid_version_1 +use constants_mod, only: DEG_TO_RAD implicit none @@ -38,17 +39,17 @@ program test_get_grid_v1 integer :: is, ie, js, je !< Starting and ending compute !! domain indices integer :: nlon, nlat !< Number of lat, lon in grid -real :: min_lon, max_lon !< Maximum lat and lon -real, dimension(:,:), allocatable :: lon, lat !< Lat and lon +real(DO_TEST_KIND_) :: min_lon, max_lon !< Maximum lat and lon +real(DO_TEST_KIND_), dimension(:,:), allocatable :: lon, lat !< Lat and lon integer :: ncid, err !< Netcdf integers integer :: dimid1, dimid2, dimid3, dimid4 !< Dimensions IDs integer :: varid1, varid2, varid3, varid4, varid5 !< Variable IDs -real :: lat_in(1), lon_in(1) !< Lat and lon to be written to file -real, dimension(:,:,:), allocatable :: lat_vert_in, lon_vert_in ! Date: Mon, 21 Aug 2023 13:05:47 -0400 Subject: [PATCH 02/23] Remove data_override_impl.F90 Include files for the implementation modules at the top of data_override.F90, and remove data_override_impl.F90 --- data_override/Makefile.am | 1 - data_override/data_override.F90 | 3 +++ data_override/data_override_impl.F90 | 2 -- 3 files changed, 3 insertions(+), 3 deletions(-) delete mode 100644 data_override/data_override_impl.F90 diff --git a/data_override/Makefile.am b/data_override/Makefile.am index e6dfd7fe9d..a3c1660a24 100644 --- a/data_override/Makefile.am +++ b/data_override/Makefile.am @@ -35,7 +35,6 @@ libdata_override_la_SOURCES = \ include/get_grid_version_r4.fh \ include/get_grid_version_r8.fh \ include/get_grid_version.inc \ - data_override_impl.F90 \ include/data_override_impl_r4.fh \ include/data_override_impl_r8.fh \ include/data_override_impl.inc \ diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index fe4e611c05..9fe7bd1435 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -17,6 +17,9 @@ !* License along with FMS. If not, see . !*********************************************************************** +#include "data_override_impl_r4.fh" +#include "data_override_impl_r8.fh" + !> @defgroup data_override_mod data_override_mod !> @ingroup data_override !! @brief Routines to get data in a file whose path is described in a user-provided data_table diff --git a/data_override/data_override_impl.F90 b/data_override/data_override_impl.F90 deleted file mode 100644 index d47110e0df..0000000000 --- a/data_override/data_override_impl.F90 +++ /dev/null @@ -1,2 +0,0 @@ -#include "data_override_impl_r4.fh" -#include "data_override_impl_r8.fh" From b89c8db621164eef22e0d9220a2046a4a1ceaa98 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 13:29:55 -0400 Subject: [PATCH 03/23] Use interfaces instead of class(*) procedures Replace the class(*) versions of the `data_override_*` procedures with interfaces. --- data_override/data_override.F90 | 68 +++------------------------------ 1 file changed, 6 insertions(+), 62 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 9fe7bd1435..8af7b0e24c 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -57,9 +57,12 @@ module data_override_mod !! for more information. !> @ingroup data_override_mod interface data_override - module procedure data_override_0d - module procedure data_override_2d - module procedure data_override_3d + module procedure data_override_0d_r4 + module procedure data_override_0d_r8 + module procedure data_override_2d_r4 + module procedure data_override_2d_r8 + module procedure data_override_3d_r4 + module procedure data_override_3d_r8 end interface !> Version of @ref data_override for unstructured grids @@ -187,65 +190,6 @@ subroutine data_override_unset_domains(unset_Atm, unset_Ocean, & endif ; endif end subroutine data_override_unset_domains -!> @brief Routine to perform data override for scalar fields -subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_index) - character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) - character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be - !! different from the name in NetCDF data file) - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - type(time_type), intent(in) :: time !< (target) model time - class(*), intent(out) :: data !< output data array returned by this call - integer, intent(in), optional :: data_index - - select type(data) - type is (real(r4_kind)) - call data_override_0d_r4(gridname,fieldname_code,data,time,override,data_index) - type is (real(r8_kind)) - call data_override_0d_r8(gridname,fieldname_code,data,time,override,data_index) - class default - call mpp_error(FATAL, "data_override_0d: Unsupported data type") - end select -end subroutine data_override_0d - -!> @brief This routine performs data override for 2D fields; for usage, see data_override_3d. -subroutine data_override_2d(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) - character(len=3), intent(in) :: gridname !< model grid ID - character(len=*), intent(in) :: fieldname !< field to override - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - type(time_type), intent(in) :: time !< model time - class(*), dimension(:,:), intent(inout) :: data_2D !< data returned by this call - integer, optional, intent(in) :: is_in, ie_in, js_in, je_in - - select type(data_2D) - type is (real(r4_kind)) - call data_override_2d_r4(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) - type is (real(r8_kind)) - call data_override_2d_r8(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) - class default - call mpp_error(FATAL, "data_override_2d: Unsupported data type") - end select -end subroutine data_override_2d - -!> @brief This routine performs data override for 3D fields -subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) - character(len=3), intent(in) :: gridname !< model grid ID - character(len=*), intent(in) :: fieldname_code !< field name as used in the model - logical, optional, intent(out) :: override !< true if the field has been overriden succesfully - type(time_type), intent(in) :: time !< (target) model time - integer, optional, intent(in) :: data_index - class(*), dimension(:,:,:), intent(inout) :: data !< data returned by this call - integer, optional, intent(in) :: is_in, ie_in, js_in, je_in - - select type(data) - type is (real(r4_kind)) - call data_override_3d_r4(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) - type is (real(r8_kind)) - call data_override_3d_r8(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) - class default - call mpp_error(FATAL, "data_override_3d: Unsupported data type") - end select -end subroutine data_override_3d - !> @brief Data override for 1D unstructured grids subroutine data_override_UG_1d(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID From 5dacac82ca2815b239ea9088a7abaa97f446380a Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 13:45:34 -0400 Subject: [PATCH 04/23] Fix `data_override_init` Fix `data_override_init` in the case where the optional `mode` argument is not used. --- data_override/data_override.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 8af7b0e24c..e2a4c2b81a 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -122,10 +122,10 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan call mpp_error(FATAL, "data_override_init: unsupported mode argument") end select - if (present(Atm_domain_in)) atm_mode = mode - if (present(Ocean_domain_in)) ocn_mode = mode - if (present(Ice_domain_in)) ice_mode = mode - if (present(Land_domain_in)) lnd_mode = mode + if (present(Atm_domain_in)) atm_mode = mode_selector + if (present(Ocean_domain_in)) ocn_mode = mode_selector + if (present(Ice_domain_in)) ice_mode = mode_selector + if (present(Land_domain_in)) lnd_mode = mode_selector end subroutine data_override_init !> @brief Unset domains that had previously been set for use by data_override. From 2b4b16e42a1e2d8fd91257550316b495c79f1a02 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 14:08:13 -0400 Subject: [PATCH 05/23] end module DATA_OVERRIDE_IMPL_ --- data_override/include/data_override_impl.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/data_override/include/data_override_impl.inc b/data_override/include/data_override_impl.inc index 3b78cac877..381f98712d 100644 --- a/data_override/include/data_override_impl.inc +++ b/data_override/include/data_override_impl.inc @@ -1200,4 +1200,4 @@ subroutine DATA_OVERRIDE_UG_2D_IMPL_(gridname,fieldname,data,time,override) end subroutine DATA_OVERRIDE_UG_2D_IMPL_ -end module +end module DATA_OVERRIDE_IMPL_ From eb0137c3ee6b3804dea57984bb670168cff9f061 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 15:55:58 -0400 Subject: [PATCH 06/23] Add doxygen comments to data_override.F90 --- data_override/data_override.F90 | 77 ++++++++++----------------------- 1 file changed, 24 insertions(+), 53 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index e2a4c2b81a..705565e299 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -68,14 +68,16 @@ module data_override_mod !> Version of @ref data_override for unstructured grids !> @ingroup data_override_mod interface data_override_UG - module procedure data_override_UG_1d - module procedure data_override_UG_2d + module procedure data_override_UG_1d_r4 + module procedure data_override_UG_1d_r8 + module procedure data_override_UG_2d_r4 + module procedure data_override_UG_2d_r8 end interface -integer :: atm_mode = 0 -integer :: ocn_mode = 0 -integer :: lnd_mode = 0 -integer :: ice_mode = 0 +integer :: atm_mode = 0 !> Atmosphere mode - possible values are 0 (uninitialized), r4_kind, or r8_kind +integer :: ocn_mode = 0 !> Ocean mode - possible values are 0 (uninitialized), r4_kind, or r8_kind +integer :: lnd_mode = 0 !> Land mode - possible values are 0 (uninitialized), r4_kind, or r8_kind +integer :: ice_mode = 0 !> Ice mode - possible values are 0 (uninitialized), r4_kind, or r8_kind !> @addtogroup data_override_mod !> @{ @@ -92,19 +94,23 @@ module data_override_mod !! This subroutine should be called in coupler_init after !! (ocean/atmos/land/ice)_model_init have been called. !! -!! data_override_init can be called more than once, in one call the user can pass -!! up to 4 domains of component models, at least one domain must be present in -!! any call +!! data_override_init can be called more than once. In one call the user can pass +!! up to 4 domains of component models. At least one domain must be present in +!! any call. The real precision of initialized domains can be specified via the +!! optional mode argument. If no mode is specified, r8_kind is assumed. Mixed mode +!! operation can be accomplished via multiple calls to data_override_init with +!! different mode arguments. !! !! Data_table is initialized here with default values. Users should provide "real" values !! that will override the default values. Real values can be given using data_table, each !! line of data_table contains one data_entry. Items of data_entry are comma separated. subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in, mode) - type (domain2d), intent(in), optional :: Atm_domain_in - type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in - type (domain2d), intent(in), optional :: Land_domain_in - type(domainUG) , intent(in), optional :: Land_domainUG_in - integer, intent(in), optional :: mode !< r4_kind or r8_kind + type (domain2d), intent(in), optional :: Atm_domain_in !< Atmosphere domain + type (domain2d), intent(in), optional :: Ocean_domain_in !< Ocean domain + type (domain2d), intent(in), optional :: Ice_domain_in !< Ice domain + type (domain2d), intent(in), optional :: Land_domain_in !< Land domain + type(domainUG) , intent(in), optional :: Land_domainUG_in !< Land domain, unstructured grid + integer, intent(in), optional :: mode !< Real precision of initialized domains. Possible values are r4_kind or r8_kind. integer :: mode_selector if (present(mode)) then @@ -133,9 +139,10 @@ end subroutine data_override_init !! This subroutine deallocates any data override domains that have been set. subroutine data_override_unset_domains(unset_Atm, unset_Ocean, & unset_Ice, unset_Land, must_be_set) - logical, intent(in), optional :: unset_Atm, unset_Ocean, unset_Ice, unset_Land - logical, intent(in), optional :: must_be_set - + logical, intent(in), optional :: unset_Atm, unset_Ocean, unset_Ice, unset_Land !< Set to true to unset the + !! respective domain + logical, intent(in), optional :: must_be_set !< Set to false to suppress the error when attempting to unset + !! an uninitialized domain logical :: fail_if_not_set fail_if_not_set = .true. ; if (present(must_be_set)) fail_if_not_set = must_be_set @@ -190,42 +197,6 @@ subroutine data_override_unset_domains(unset_Atm, unset_Ocean, & endif ; endif end subroutine data_override_unset_domains -!> @brief Data override for 1D unstructured grids -subroutine data_override_UG_1d(gridname,fieldname,data,time,override) - character(len=3), intent(in) :: gridname !< model grid ID - character(len=*), intent(in) :: fieldname !< field to override - class(*), dimension(:), intent(inout) :: data !< data returned by this call - type(time_type), intent(in) :: time !< model time - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - - select type(data) - type is (real(r4_kind)) - call data_override_UG_1d_r4(gridname,fieldname,data,time,override) - type is (real(r8_kind)) - call data_override_UG_1d_r8(gridname,fieldname,data,time,override) - class default - call mpp_error(FATAL, "data_override_UG_1d: Unsupported data type") - end select -end subroutine data_override_UG_1d - -!> @brief Data override for 2D unstructured grids -subroutine data_override_UG_2d(gridname,fieldname,data,time,override) - character(len=3), intent(in) :: gridname !< model grid ID - character(len=*), intent(in) :: fieldname !< field to override - class(*), dimension(:,:), intent(inout) :: data !< data returned by this call - type(time_type), intent(in) :: time !< model time - logical, intent(out), optional :: override !< true if the field has been overriden succesfully - - select type(data) - type is (real(r4_kind)) - call data_override_UG_2d_r4(gridname,fieldname,data,time,override) - type is (real(r8_kind)) - call data_override_UG_2d_r8(gridname,fieldname,data,time,override) - class default - call mpp_error(FATAL, "data_override_UG_2d: Unsupported data type") - end select -end subroutine data_override_UG_2d - end module data_override_mod !> @} ! close documentation grouping From e960b140ae46b8d56cf66737527af978828d62b6 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 16:13:34 -0400 Subject: [PATCH 07/23] Update and clarify doxygen comments --- data_override/data_override.F90 | 10 +++++----- data_override/include/data_override_impl.inc | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 705565e299..37a685ed9e 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -87,8 +87,7 @@ module data_override_mod contains -!> @brief Assign default values for default_table, get domain of component models, -!! get global grids of component models. +!> @brief Initialize either data_override_r4 or data_override_r8 !! Users should call data_override_init before calling data_override !! !! This subroutine should be called in coupler_init after @@ -101,9 +100,10 @@ module data_override_mod !! operation can be accomplished via multiple calls to data_override_init with !! different mode arguments. !! -!! Data_table is initialized here with default values. Users should provide "real" values -!! that will override the default values. Real values can be given using data_table, each -!! line of data_table contains one data_entry. Items of data_entry are comma separated. +!! Data_table is initialized with default values in DATA_OVERRIDE_INIT_IMPL_. Users should +!! provide "real" values that will override the default values. Real values can be +!! specified in either data_table or data_table.yaml. Each line of data_table contains one +!! data_entry. Items of data_entry are comma-separated. subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in, mode) type (domain2d), intent(in), optional :: Atm_domain_in !< Atmosphere domain type (domain2d), intent(in), optional :: Ocean_domain_in !< Ocean domain diff --git a/data_override/include/data_override_impl.inc b/data_override/include/data_override_impl.inc index 381f98712d..34c91c7465 100644 --- a/data_override/include/data_override_impl.inc +++ b/data_override/include/data_override_impl.inc @@ -642,7 +642,7 @@ subroutine DATA_OVERRIDE_0D_IMPL_(gridname,fieldname_code,data,time,override,dat end subroutine DATA_OVERRIDE_0D_IMPL_ -!> @brief This routine performs data override for 2D fields; for usage, see data_override_3d. +!> @brief This routine performs data override for 2D fields. subroutine DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override From 2d6bfd6da5004ab00e7be60e8e85f13cbfa96827 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 21 Aug 2023 16:29:11 -0400 Subject: [PATCH 08/23] Add doxygen comment for DATA_OVERRIDE_INIT_IMPL_ --- data_override/include/data_override_impl.inc | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/data_override/include/data_override_impl.inc b/data_override/include/data_override_impl.inc index 34c91c7465..a35bfc5c9d 100644 --- a/data_override/include/data_override_impl.inc +++ b/data_override/include/data_override_impl.inc @@ -106,6 +106,16 @@ use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 contains +!> @brief Assign default values for default_table, get domain of component models, +!! get global grids of component models. +!! Users should call data_override_init before calling data_override +!! +!! This subroutine should be called by data_override_init. +!! +!! Data_table is initialized here with default values. Users should provide "real" values +!! that will override the default values. Real values can be specified in either data_table +!! or data_table.yaml. Each line of data_table contains one data_entry. Items of data_entry +!! are comma-separated. subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) type (domain2d), intent(in), optional :: Atm_domain_in type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in From 3ca07987267d8078cd58ee27aa86feeb5dfd9ef2 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 22 Aug 2023 14:37:44 -0400 Subject: [PATCH 09/23] Fix r4_kind unit tests --- test_fms/data_override/test_data_override.F90 | 106 +++++++++--------- test_fms/data_override/test_data_override2.sh | 59 ++++------ .../test_data_override_ongrid.F90 | 61 +++++----- test_fms/data_override/test_get_grid_v1.F90 | 41 ++++--- 4 files changed, 126 insertions(+), 141 deletions(-) diff --git a/test_fms/data_override/test_data_override.F90 b/test_fms/data_override/test_data_override.F90 index b104755b4f..4b4c3650ba 100644 --- a/test_fms/data_override/test_data_override.F90 +++ b/test_fms/data_override/test_data_override.F90 @@ -95,31 +95,33 @@ program test implicit none - integer :: stdoutunit - integer :: num_threads = 1 - integer :: isw, iew, jsw, jew - integer, allocatable :: is_win(:), js_win(:) - integer :: nx_dom, ny_dom, nx_win, ny_win - type(domain2d) :: Domain - integer :: nlon, nlat, siz(2) - real(DO_TEST_KIND_), allocatable, dimension(:) :: x, y - real(DO_TEST_KIND_), allocatable, dimension(:,:) :: lon, lat - real(DO_TEST_KIND_), allocatable, dimension(:,:) :: sst, ice - integer :: id_x, id_y, id_lon, id_lat, id_sst, id_ice - integer :: i, j, is, ie, js, je, io, ierr, n - real(DO_TEST_KIND_) :: rad_to_deg - character(len=36) :: message - type(time_type) :: Time - logical :: used - logical, allocatable :: ov_sst(:), ov_ice(:) - integer, dimension(2) :: layout = (/0,0/) - character(len=256) :: solo_mosaic_file, tile_file - character(len=128) :: grid_file = "INPUT/grid_spec.nc" - integer :: window(2) = (/1,1/) - integer :: nthreads=1 - integer :: nwindows - integer :: nx_cubic=90, ny_cubic=90, nx_latlon=90, ny_latlon=90 - integer :: test_num=1 !* 1 for unstruct cubic grid, 2 for unstruct latlon-grid + integer, parameter :: lkind = DO_TEST_KIND_ + integer :: stdoutunit + integer :: num_threads = 1 + integer :: isw, iew, jsw, jew + integer, allocatable :: is_win(:), js_win(:) + integer :: nx_dom, ny_dom, nx_win, ny_win + type(domain2d) :: Domain + integer :: nlon, nlat, siz(2) + real(lkind), allocatable, dimension(:) :: x, y + real(lkind), allocatable, dimension(:,:) :: lon, lat + real(lkind), allocatable, dimension(:,:) :: sst, ice + integer :: id_x, id_y, id_lon, id_lat, id_sst, id_ice + integer :: i, j, is, ie, js, je, io, ierr, n + real(lkind) :: rad_to_deg + character(len=36) :: message + type(time_type) :: Time + logical :: used + logical, allocatable :: ov_sst(:), ov_ice(:) + integer, dimension(2) :: layout = (/0,0/) + character(len=256) :: solo_mosaic_file, tile_file + character(len=128) :: grid_file = "INPUT/grid_spec.nc" + integer :: window(2) = (/1,1/) + integer :: nthreads=1 + integer :: nwindows + integer :: nx_cubic=90, ny_cubic=90, nx_latlon=90, ny_latlon=90 + integer :: test_num=1 !> 1 for unstruct cubic grid, 2 for unstruct + !! latlon-grid type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile @@ -173,8 +175,8 @@ program test call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, name='test_data_override') call mpp_define_io_domain(Domain, (/1,1/)) - call data_override_init(Ice_domain_in=Domain, Ocean_domain_in=Domain) - call data_override_init(Ice_domain_in=Domain, Ocean_domain_in=Domain) + call data_override_init(Ice_domain_in=Domain, Ocean_domain_in=Domain, mode=lkind) + call data_override_init(Ice_domain_in=Domain, Ocean_domain_in=Domain, mode=lkind) call mpp_get_compute_domain(Domain, is, ie, js, je) call get_grid @@ -322,10 +324,10 @@ program test !==================================================================================================================== subroutine get_grid - real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo - real(DO_TEST_KIND_), allocatable, dimension(:,:) :: lon_global, lat_global - integer, dimension(2) :: siz - character(len=128) :: message + real(lkind), allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo + real(lkind), allocatable, dimension(:,:) :: lon_global, lat_global + integer, dimension(2) :: siz + character(len=128) :: message type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile @@ -419,14 +421,14 @@ subroutine test_unstruct_grid( type, Time ) integer :: isc, iec, jsc, jec, isd, ied, jsd, jed integer :: ism, iem, jsm, jem, lsg, leg - integer, allocatable, dimension(:) :: pe_start, pe_end, npts_tile, grid_index, ntiles_grid - integer, allocatable, dimension(:,:) :: layout2D, global_indices - real(DO_TEST_KIND_), allocatable, dimension(:,:) :: x1, x2, g1, g2 - real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: a1, a2, gdata - real(DO_TEST_KIND_), allocatable, dimension(:,:) :: rmask - real(DO_TEST_KIND_), allocatable, dimension(:) :: frac_crit - logical, allocatable, dimension(:,:,:) :: lmask,msk - integer, allocatable, dimension(:) :: isl, iel, jsl, jel + integer, allocatable, dimension(:) :: pe_start, pe_end, npts_tile, grid_index, ntiles_grid + integer, allocatable, dimension(:,:) :: layout2D, global_indices + real(lkind), allocatable, dimension(:,:) :: x1, x2, g1, g2 + real(lkind), allocatable, dimension(:,:,:) :: a1, a2, gdata + real(lkind), allocatable, dimension(:,:) :: rmask + real(lkind), allocatable, dimension(:) :: frac_crit + logical, allocatable, dimension(:,:,:) :: lmask,msk + integer, allocatable, dimension(:) :: isl, iel, jsl, jel character(len=3) :: text integer :: tile integer :: ntotal_land, istart, iend, pos @@ -577,7 +579,7 @@ subroutine test_unstruct_grid( type, Time ) enddo enddo !First override the test SG data from file/field - call data_override_init(Land_domain_in=SG_domain) + call data_override_init(Land_domain_in=SG_domain, mode=lkind) call data_override('LND','sst_obs',a1(:,:,1),Time) !Create the test UG data @@ -594,7 +596,7 @@ subroutine test_unstruct_grid( type, Time ) !--- fill the value of x2 !Now override the test UG data from the same file/field - call data_override_init(Land_domainUG_in=UG_domain) + call data_override_init(Land_domainUG_in=UG_domain, mode=lkind) call data_override_UG('LND','sst_obs',x2(:,1),Time) !Ensure you get the same UG data from the SG data @@ -621,7 +623,7 @@ subroutine test_unstruct_grid( type, Time ) ! enddo !First override the test SG data from file/field - call data_override_init(Land_domain_in=SG_domain) + call data_override_init(Land_domain_in=SG_domain, mode=lkind) call data_override('LND','sst_obs',a1,Time) a2 = -999 @@ -652,7 +654,7 @@ subroutine test_unstruct_grid( type, Time ) ! enddo !Now override the test UG data from the same file/field - call data_override_init(Land_domainUG_in=UG_domain) + call data_override_init(Land_domainUG_in=UG_domain, mode=lkind) call data_override_UG('LND','sst_obs',x2,Time) !Ensure you get the same UG data from the SG data @@ -667,10 +669,10 @@ subroutine test_unstruct_grid( type, Time ) end subroutine test_unstruct_grid subroutine compare_checksums( a, b, string ) - real(DO_TEST_KIND_), intent(in), dimension(:,:,:) :: a, b - character(len=*), intent(in) :: string - integer(i8_kind) :: sum1, sum2 - integer :: i, j, k,pe + real(lkind), intent(in), dimension(:,:,:) :: a, b + character(len=*), intent(in) :: string + integer(i8_kind) :: sum1, sum2 + integer :: i, j, k,pe ! z1l can not call mpp_sync here since there might be different number of tiles on each pe. ! mpp_sync() @@ -712,10 +714,10 @@ end subroutine compare_checksums !########################################################################### subroutine compare_checksums_2D( a, b, string ) - real(DO_TEST_KIND_), intent(in), dimension(:,:) :: a, b - character(len=*), intent(in) :: string - integer(i8_kind) :: sum1, sum2 - integer :: i, j,pe + real(lkind), intent(in), dimension(:,:) :: a, b + character(len=*), intent(in) :: string + integer(i8_kind) :: sum1, sum2 + integer :: i, j,pe ! z1l can not call mpp_sync here since there might be different number of tiles on each pe. ! mpp_sync() @@ -761,7 +763,7 @@ subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_ integer, dimension(12) :: istart1, iend1, jstart1, jend1, tile1 integer, dimension(12) :: istart2, iend2, jstart2, jend2, tile2 integer :: ntiles, num_contact, msize(2) - integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 + integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 ntiles = 6 diff --git a/test_fms/data_override/test_data_override2.sh b/test_fms/data_override/test_data_override2.sh index 33a7866f67..35546b41d3 100755 --- a/test_fms/data_override/test_data_override2.sh +++ b/test_fms/data_override/test_data_override2.sh @@ -24,9 +24,6 @@ # Set common test settings. . ../test-lib.sh -# Skip test if input not present -test -z "$test_input_path" && SKIP_TESTS="$SKIP_TESTS $(basename $0 .sh).4" - setup_test_dir () { local halo_size test "$#" = 1 && { halo_size=$1; } || @@ -45,9 +42,12 @@ _EOF mkdir INPUT } -# Run the ongrid test case with 2 halos in x and y touch input.nml +for KIND in r4 r8 +do + +# Run the ongrid test case with 2 halos in x and y cat <<_EOF > data_table.yaml data_table: - gridname : OCN @@ -62,29 +62,20 @@ printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180 [ ! -d "INPUT" ] && mkdir -p "INPUT" setup_test_dir 2 -for KIND in r4 r8 -do - test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' - mpirun -n 6 ./test_data_override_ongrid_${KIND} - ' -done +test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' + mpirun -n 6 ./test_data_override_ongrid_${KIND} +' setup_test_dir 0 -for KIND in r4 r8 -do - test_expect_success "data_override on grid with no halos (${KIND})" ' - mpirun -n 6 ./test_data_override_ongrid_${KIND} - ' -done +test_expect_success "data_override on grid with no halos (${KIND})" ' + mpirun -n 6 ./test_data_override_ongrid_${KIND} +' # Run the get_grid_v1 test: -for KIND in r4 r8 -do - test_expect_success "data_override get_grid_v1 (${KIND})" ' - mpirun -n 1 ./test_get_grid_v1_${KIND} - ' -done +test_expect_success "data_override get_grid_v1 (${KIND})" ' + mpirun -n 1 ./test_get_grid_v1_${KIND} +' # Run tests with input if enabled # skips if built with yaml parser(tests older behavior) @@ -101,7 +92,6 @@ test_data_override "test_data_override_mod", "sst", "sst", "test_data_override", "all", .false., "none", 2 "test_data_override_mod", "ice", "ice", "test_data_override", "all", .false., "none", 2 _EOF - cat <<_EOF > data_table "ICE", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .false., 300.0 "ICE", "sic_obs", "SIC", "INPUT/sst_ice_clim.nc", .false., 300.0 @@ -109,27 +99,22 @@ _EOF "LND", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .false., 300.0 _EOF - for KIND in r4 r8 - do - test_expect_success "data_override on cubic-grid with input (${KIND})" ' - mpirun -n 6 ./test_data_override_${KIND} - ' - done + test_expect_success "data_override on cubic-grid with input (${KIND})" ' + mpirun -n 6 ./test_data_override_${KIND} + ' - cat <<_EOF > input.nml +cat <<_EOF > input.nml &test_data_override_nml test_num=2 / _EOF - for KIND in r4 r8 - do - test_expect_success "data_override on latlon-grid with input (${KIND})" ' - mpirun -n 6 ./test_data_override_${KIND} - ' - done - + test_expect_success "data_override on latlon-grid with input (${KIND})" ' + mpirun -n 6 ./test_data_override_${KIND} + ' rm -rf INPUT *.nc # remove any leftover files to reduce size fi +done + 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 c976382814..3f031547fa 100644 --- a/test_fms/data_override/test_data_override_ongrid.F90 +++ b/test_fms/data_override/test_data_override_ongrid.F90 @@ -36,26 +36,26 @@ program test_data_override_ongrid implicit none -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 -type(domain2d) :: Domain !< Domain with mask table -real(DO_TEST_KIND_), allocatable, dimension(:,:) :: runoff !< Data to be written -integer :: is !< Starting x index -integer :: ie !< Ending x index -integer :: js !< Starting y index -integer :: je !< Ending y index -type(time_type) :: Time !< Time -integer :: i !< Helper indices -integer :: ncid !< Netcdf file id -integer :: err !< Error Code -integer :: dim1d, dim2d, dim3d, dim4d !< Dimension ids -integer :: varid, varid2, varid3, varid4 !< Variable ids -real(DO_TEST_KIND_), allocatable, dimension(:,:,:) :: runoff_in !< Data to be written to file -real(DO_TEST_KIND_) :: expected_result !< Expected result from data_override -integer :: nhalox=2, nhaloy=2 -integer :: io_status +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 +type(domain2d) :: Domain !< Domain with mask table +real(lkind), allocatable, dimension(:,:) :: runoff !< Data to be written +integer :: is !< Starting x index +integer :: ie !< Ending x index +integer :: js !< Starting y index +integer :: je !< Ending y index +type(time_type) :: Time !< Time +integer :: i !< Helper indices +integer :: ncid !< Netcdf file id +integer :: err !< Error Code +integer :: dim1d, dim2d, dim3d, dim4d !< Dimension ids +integer :: varid, varid2, varid3, varid4 !< Variable ids +real(lkind), allocatable, dimension(:,:,:) :: runoff_in !< Data to be written to file +real(lkind) :: expected_result !< Expected result from data_override +integer :: nhalox=2, nhaloy=2 +integer :: io_status namelist / test_data_override_ongrid_nml / nhalox, nhaloy @@ -69,7 +69,7 @@ program test_data_override_ongrid if (mpp_pe() .eq. mpp_root_pe()) then allocate(runoff_in(1440, 1080, 10)) do i = 1, 10 - runoff_in(:,:,i) = real(i, DO_TEST_KIND_) + runoff_in(:,:,i) = real(i, lkind) enddo err = nf90_create('INPUT/grid_spec.nc', ior(nf90_clobber, nf90_64bit_offset), ncid) @@ -148,7 +148,7 @@ program test_data_override_ongrid runoff = 999. !< Initiliaze data_override -call data_override_init(Ocean_domain_in=Domain) +call data_override_init(Ocean_domain_in=Domain, mode=lkind) !< Run it when time=3 Time = set_date(1,1,4,0,0,0) @@ -174,15 +174,14 @@ program test_data_override_ongrid contains subroutine compare_data(Domain, actual_result, expected_result) -type(domain2d), intent(in) :: Domain !< Domain with mask table -real(DO_TEST_KIND_), intent(in) :: expected_result !< Expected result from data_override -real(DO_TEST_KIND_), dimension(:,:), intent(in) :: actual_result !< Result from data_override - -integer :: xsizec, ysizec !< Size of the compute domain -integer :: xsized, ysized !< Size of the data domain -integer :: nx, ny !< Size of acual_result -integer :: nhalox, nhaloy !< Size of the halos -integer :: i, j !< Helper indices +type(domain2d), intent(in) :: Domain !< Domain with mask table +real(lkind), intent(in) :: expected_result !< Expected result from data_override +real(lkind), dimension(:,:), intent(in) :: actual_result !< Result from data_override +integer :: xsizec, ysizec !< Size of the compute domain +integer :: xsized, ysized !< Size of the data domain +integer :: nx, ny !< Size of acual_result +integer :: nhalox, nhaloy !< Size of the halos +integer :: i, j !< Helper indices !< Data is only expected to be overriden for the compute domain -not at the halos. call mpp_get_compute_domain(Domain, xsize=xsizec, ysize=ysizec) diff --git a/test_fms/data_override/test_get_grid_v1.F90 b/test_fms/data_override/test_get_grid_v1.F90 index fe4c1127e3..f8466bfd62 100644 --- a/test_fms/data_override/test_get_grid_v1.F90 +++ b/test_fms/data_override/test_get_grid_v1.F90 @@ -35,21 +35,20 @@ program test_get_grid_v1 implicit none -type(domain2d) :: Domain !< 2D domain -integer :: is, ie, js, je !< Starting and ending compute - !! domain indices -integer :: nlon, nlat !< Number of lat, lon in grid -real(DO_TEST_KIND_) :: min_lon, max_lon !< Maximum lat and lon -real(DO_TEST_KIND_), dimension(:,:), allocatable :: lon, lat !< Lat and lon -integer :: ncid, err !< Netcdf integers -integer :: dimid1, dimid2, dimid3, dimid4 !< Dimensions IDs -integer :: varid1, varid2, varid3, varid4, varid5 !< Variable IDs -real(DO_TEST_KIND_) :: lat_in(1), lon_in(1) !< Lat and lon to be written to file -real(DO_TEST_KIND_), dimension(:,:,:), allocatable :: lat_vert_in, lon_vert_in ! Date: Tue, 22 Aug 2023 15:09:15 -0400 Subject: [PATCH 10/23] Split long lines --- data_override/data_override.F90 | 3 ++- test_fms/data_override/test_get_grid_v1.F90 | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 37a685ed9e..c65d7bdece 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -110,7 +110,8 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan type (domain2d), intent(in), optional :: Ice_domain_in !< Ice domain type (domain2d), intent(in), optional :: Land_domain_in !< Land domain type(domainUG) , intent(in), optional :: Land_domainUG_in !< Land domain, unstructured grid - integer, intent(in), optional :: mode !< Real precision of initialized domains. Possible values are r4_kind or r8_kind. + integer, intent(in), optional :: mode !< Real precision of initialized domains. Possible values are r4_kind or + !! r8_kind. integer :: mode_selector if (present(mode)) then diff --git a/test_fms/data_override/test_get_grid_v1.F90 b/test_fms/data_override/test_get_grid_v1.F90 index f8466bfd62..2fa6a2c45b 100644 --- a/test_fms/data_override/test_get_grid_v1.F90 +++ b/test_fms/data_override/test_get_grid_v1.F90 @@ -91,8 +91,10 @@ program test_get_grid_v1 min_lon, max_lon) !< Error checking: -if (lon(1,1) .ne. lon_in(1)*real(DEG_TO_RAD, lkind)) call mpp_error(FATAL,'test_get_grid_v1: lon is not the expected result') -if (lat(1,1) .ne. lat_in(1)*real(DEG_TO_RAD, lkind)) call mpp_error(FATAL,'test_get_grid_v1: lat is not the expected result') +if (lon(1,1) .ne. lon_in(1)*real(DEG_TO_RAD, lkind)) & + & call mpp_error(FATAL,'test_get_grid_v1: lon is not the expected result') +if (lat(1,1) .ne. lat_in(1)*real(DEG_TO_RAD, lkind)) & + & call mpp_error(FATAL,'test_get_grid_v1: lat is not the expected result') !< Try again with ocean lat = 0. From bbf8b19f3c05cfc7a02cdf46af71926d4e69e844 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 22 Aug 2023 19:20:20 -0400 Subject: [PATCH 11/23] Add data_override/include to CMakeLists.txt --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 6983d1d568..75afa93d8d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -317,7 +317,8 @@ foreach(kind ${kinds}) field_manager/include time_interp/include tracer_manager/include - interpolator/include) + interpolator/include + data_override/include) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") From de4a15d78e180b0e6d9b05f0d11fd4c8061ffbfd Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 23 Aug 2023 12:13:50 -0400 Subject: [PATCH 12/23] Add data_override/include to CMakeLists.txt --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 75afa93d8d..ab8f031872 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -366,7 +366,8 @@ foreach(kind ${kinds}) $ $ $ - $) + $ + $) target_include_directories(${libTgt} INTERFACE From db69da25d378ae23f29ef50da5cca4cfdc6dfd86 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 23 Aug 2023 16:16:36 -0400 Subject: [PATCH 13/23] Rename data_override include files --- data_override/Makefile.am | 6 +++--- data_override/data_override.F90 | 4 ++-- .../include/{data_override_impl.inc => data_override.inc} | 0 .../{data_override_impl_r4.fh => data_override_r4.fh} | 2 +- .../{data_override_impl_r8.fh => data_override_r8.fh} | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) rename data_override/include/{data_override_impl.inc => data_override.inc} (100%) rename data_override/include/{data_override_impl_r4.fh => data_override_r4.fh} (97%) rename data_override/include/{data_override_impl_r8.fh => data_override_r8.fh} (97%) diff --git a/data_override/Makefile.am b/data_override/Makefile.am index a3c1660a24..e1228f3099 100644 --- a/data_override/Makefile.am +++ b/data_override/Makefile.am @@ -35,9 +35,9 @@ libdata_override_la_SOURCES = \ include/get_grid_version_r4.fh \ include/get_grid_version_r8.fh \ include/get_grid_version.inc \ - include/data_override_impl_r4.fh \ - include/data_override_impl_r8.fh \ - include/data_override_impl.inc \ + include/data_override_r4.fh \ + include/data_override_r8.fh \ + include/data_override.inc \ data_override.F90 # Some mods are dependent on other mods in this dir. diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index c65d7bdece..ff79e35e45 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** -#include "data_override_impl_r4.fh" -#include "data_override_impl_r8.fh" +#include "data_override_r4.fh" +#include "data_override_r8.fh" !> @defgroup data_override_mod data_override_mod !> @ingroup data_override diff --git a/data_override/include/data_override_impl.inc b/data_override/include/data_override.inc similarity index 100% rename from data_override/include/data_override_impl.inc rename to data_override/include/data_override.inc diff --git a/data_override/include/data_override_impl_r4.fh b/data_override/include/data_override_r4.fh similarity index 97% rename from data_override/include/data_override_impl_r4.fh rename to data_override/include/data_override_r4.fh index ed2b995a79..e2fdcf3217 100644 --- a/data_override/include/data_override_impl_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -34,7 +34,7 @@ #undef DATA_OVERRIDE_UG_2D_IMPL_ #define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r4 -#include "data_override_impl.inc" +#include "data_override.inc" #undef DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_IMPL_ diff --git a/data_override/include/data_override_impl_r8.fh b/data_override/include/data_override_r8.fh similarity index 97% rename from data_override/include/data_override_impl_r8.fh rename to data_override/include/data_override_r8.fh index fd711d6764..50eb965062 100644 --- a/data_override/include/data_override_impl_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -34,7 +34,7 @@ #undef DATA_OVERRIDE_UG_2D_IMPL_ #define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r8 -#include "data_override_impl.inc" +#include "data_override.inc" #undef DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_IMPL_ From 2478bf6cf73db4c1126b1b29a50edd75a1deefae Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 23 Aug 2023 16:48:31 -0400 Subject: [PATCH 14/23] Document DATA_OVERRIDE_INIT_IMPL_ arguments --- data_override/include/data_override.inc | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index a35bfc5c9d..0d5c21b0b9 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -117,10 +117,11 @@ use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 !! or data_table.yaml. Each line of data_table contains one data_entry. Items of data_entry !! are comma-separated. subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Land_domain_in, Land_domainUG_in) - type (domain2d), intent(in), optional :: Atm_domain_in - type (domain2d), intent(in), optional :: Ocean_domain_in, Ice_domain_in - type (domain2d), intent(in), optional :: Land_domain_in - type(domainUG) , intent(in), optional :: Land_domainUG_in + type (domain2d), intent(in), optional :: Atm_domain_in !> Atmosphere domain + type (domain2d), intent(in), optional :: Ocean_domain_in !> Ocean domain + type (domain2d), intent(in), optional :: Ice_domain_in !> Ice domain + 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' integer :: is,ie,js,je,use_get_grid_version From 303141e6a8cd347fb15915836d91845eec333d07 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Thu, 24 Aug 2023 12:26:04 -0400 Subject: [PATCH 15/23] Revise Makefile.am --- data_override/Makefile.am | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/data_override/Makefile.am b/data_override/Makefile.am index e1228f3099..8f7856a83d 100644 --- a/data_override/Makefile.am +++ b/data_override/Makefile.am @@ -35,23 +35,18 @@ libdata_override_la_SOURCES = \ include/get_grid_version_r4.fh \ include/get_grid_version_r8.fh \ include/get_grid_version.inc \ + data_override.F90 \ include/data_override_r4.fh \ include/data_override_r8.fh \ - include/data_override.inc \ - data_override.F90 + include/data_override.inc # Some mods are dependent on other mods in this dir. -data_override_r4.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) -data_override_r8.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) -data_override_mod.$(FC_MODEXT): \ - data_override_r4.$(FC_MODEXT) \ - data_override_r8.$(FC_MODEXT) +data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) +data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ data_override_mod.$(FC_MODEXT) \ - data_override_r4.$(FC_MODEXT) \ - data_override_r8.$(FC_MODEXT) \ get_grid_version_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) From 59bf15d438dca05b9481e4372e8616b7794c3476 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Thu, 24 Aug 2023 13:08:03 -0400 Subject: [PATCH 16/23] Add doxygen comments for `count_ne_1` --- data_override/include/data_override.inc | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 0d5c21b0b9..01c7497ab5 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -287,8 +287,22 @@ endif end if end subroutine DATA_OVERRIDE_INIT_IMPL_ +!> @brief Implementation of the following truth table: +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Arg 1 Arg 2 Arg 3 | Result !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! .true. .true. .true. | .true. !! +!! .true. .true. .false. | .true. !! +!! .true. .false. .true. | .true. !! +!! .true. .false. .false. | .false. !! +!! .false. .true. .true. | .true. !! +!! .false. .true. .false. | .false. !! +!! .false. .false. .true. | .false. !! +!! .false. .false. .false. | .true. !! function count_ne_1(in_1, in_2, in_3) - logical, intent(in) :: in_1, in_2, in_3 + logical, intent(in) :: in_1 !< Argument 1 + logical, intent(in) :: in_2 !< Argument 2 + logical, intent(in) :: in_3 !< Argument 3 logical :: count_ne_1 count_ne_1 = .not.(in_1.NEQV.in_2.NEQV.in_3) .OR. (in_1.AND.in_2.AND.in_3) From fba5123db8f1be8c6e40b2527bab8e84da4e8085 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 25 Aug 2023 11:01:07 -0400 Subject: [PATCH 17/23] Add GPL header to include files --- data_override/include/data_override.inc | 19 +++++++++++++++++++ data_override/include/data_override_r4.fh | 19 +++++++++++++++++++ data_override/include/data_override_r8.fh | 19 +++++++++++++++++++ data_override/include/get_grid_version_r4.fh | 19 +++++++++++++++++++ data_override/include/get_grid_version_r8.fh | 19 +++++++++++++++++++ 5 files changed, 95 insertions(+) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 01c7497ab5..55d7b798b3 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -1,3 +1,22 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + module DATA_OVERRIDE_IMPL_ use platform_mod, only: r4_kind, r8_kind use yaml_parser_mod diff --git a/data_override/include/data_override_r4.fh b/data_override/include/data_override_r4.fh index e2fdcf3217..a6bce7022a 100644 --- a/data_override/include/data_override_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -1,3 +1,22 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + #undef DATA_OVERRIDE_KIND_ #define DATA_OVERRIDE_KIND_ r4_kind diff --git a/data_override/include/data_override_r8.fh b/data_override/include/data_override_r8.fh index 50eb965062..61878bd919 100644 --- a/data_override/include/data_override_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -1,3 +1,22 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + #undef DATA_OVERRIDE_KIND_ #define DATA_OVERRIDE_KIND_ r8_kind diff --git a/data_override/include/get_grid_version_r4.fh b/data_override/include/get_grid_version_r4.fh index d581c55ff0..acea79cb08 100644 --- a/data_override/include/get_grid_version_r4.fh +++ b/data_override/include/get_grid_version_r4.fh @@ -1,3 +1,22 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + #undef GET_GRID_VERSION_KIND_ #define GET_GRID_VERSION_KIND_ r4_kind diff --git a/data_override/include/get_grid_version_r8.fh b/data_override/include/get_grid_version_r8.fh index eb4115c64e..0d8ff56df5 100644 --- a/data_override/include/get_grid_version_r8.fh +++ b/data_override/include/get_grid_version_r8.fh @@ -1,3 +1,22 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + #undef GET_GRID_VERSION_KIND_ #define GET_GRID_VERSION_KIND_ r8_kind From bfcba86e2ff968293a6d653b5ddd898d9cf63856 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 25 Aug 2023 11:30:06 -0400 Subject: [PATCH 18/23] Attempt to fix CMake build --- data_override/include/data_override.inc | 190 +++++++++++----------- data_override/include/data_override_r4.fh | 5 +- data_override/include/data_override_r8.fh | 5 +- 3 files changed, 96 insertions(+), 104 deletions(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 55d7b798b3..f362072a0a 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -17,113 +17,112 @@ !* License along with FMS. If not, see . !*********************************************************************** -module DATA_OVERRIDE_IMPL_ - use platform_mod, only: r4_kind, r8_kind - 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(=) - use time_interp_external2_mod, only: time_interp_external_init, & - time_interp_external, & - init_external_field, & - get_external_field_size, & - set_override_region, & - reset_src_data_region, & - NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & - get_external_fileobj - use fms_mod, only: write_version_number, lowercase, check_nml_error - use axis_utils2_mod, only : nearest_index, axis_edges - use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.) - use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain - use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG - use time_manager_mod, only: time_type - use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & - read_data, fms2_io_init, variable_exists, & - get_mosaic_tile_file +use platform_mod, only: r4_kind, r8_kind +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(=) +use time_interp_external2_mod, only: time_interp_external_init, & + time_interp_external, & + init_external_field, & + get_external_field_size, & + set_override_region, & + reset_src_data_region, & + NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & + get_external_fileobj +use fms_mod, only: write_version_number, lowercase, check_nml_error +use axis_utils2_mod, only : nearest_index, axis_edges +use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.) +use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain +use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG +use time_manager_mod, only: time_type +use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & + read_data, fms2_io_init, variable_exists, & + get_mosaic_tile_file use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 - implicit none - private +implicit none +private ! Include variable "version" to be written to log file. #include - !> Private type for holding field and grid information from a data table - !> @ingroup data_override_mod - 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=128) :: interpol_method !< interpolation method (default "bilinear") - real(DATA_OVERRIDE_KIND_) :: factor !< For unit conversion, default=1, see OVERVIEW above - real(DATA_OVERRIDE_KIND_) :: lon_start, lon_end, lat_start, lat_end - integer :: region_type - end type data_type - - !> Private type for holding various data fields for performing data overrides - !> @ingroup data_override_mod - type override_type - character(len=3) :: gridname - character(len=128) :: fieldname - integer :: t_index !< index for time interp - type(horiz_interp_type), allocatable :: horz_interp(:) !< index for horizontal spatial interp - integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename - integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain - integer :: numthreads - real(DATA_OVERRIDE_KIND_), allocatable :: lon_in(:) - real(DATA_OVERRIDE_KIND_), allocatable :: lat_in(:) - logical, allocatable :: need_compute(:) - integer :: numwindows - integer :: window_size(2) - integer :: is_src, ie_src, js_src, je_src - end type override_type - - integer, parameter :: lkind = DATA_OVERRIDE_KIND_ - integer, parameter :: max_table=100, max_array=100 - - integer :: table_size !< actual size of data table - logical :: module_is_initialized = .FALSE. - - type(domain2D) :: ocn_domain,atm_domain,lnd_domain, ice_domain - type(domainUG) :: lnd_domainUG - - real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn - real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm - real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice - real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd - real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ocn, max_glo_lon_ocn - real(DATA_OVERRIDE_KIND_) :: min_glo_lon_atm, max_glo_lon_atm - real(DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd - real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice - integer :: num_fields = 0 !< number of fields in override_array already processed +!> Private type for holding field and grid information from a data table +!> @ingroup data_override_mod +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=128) :: interpol_method !< interpolation method (default "bilinear") + real(DATA_OVERRIDE_KIND_) :: factor !< For unit conversion, default=1, see OVERVIEW above + real(DATA_OVERRIDE_KIND_) :: lon_start, lon_end, lat_start, lat_end + integer :: region_type +end type data_type + +!> Private type for holding various data fields for performing data overrides +!> @ingroup data_override_mod +type override_type + character(len=3) :: gridname + character(len=128) :: fieldname + integer :: t_index !< index for time interp + type(horiz_interp_type), allocatable :: horz_interp(:) !< index for horizontal spatial interp + integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename + integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain + integer :: numthreads + real(DATA_OVERRIDE_KIND_), allocatable :: lon_in(:) + real(DATA_OVERRIDE_KIND_), allocatable :: lat_in(:) + logical, allocatable :: need_compute(:) + integer :: numwindows + integer :: window_size(2) + integer :: is_src, ie_src, js_src, je_src +end type override_type + +integer, parameter :: lkind = DATA_OVERRIDE_KIND_ +integer, parameter :: max_table=100, max_array=100 + +integer :: table_size !< actual size of data table +logical :: module_is_initialized = .FALSE. + +type(domain2D) :: ocn_domain,atm_domain,lnd_domain, ice_domain +type(domainUG) :: lnd_domainUG + +real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn +real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm +real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice +real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd +real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ocn, max_glo_lon_ocn +real(DATA_OVERRIDE_KIND_) :: min_glo_lon_atm, max_glo_lon_atm +real(DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd +real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice +integer :: num_fields = 0 !< number of fields in override_array already processed #ifdef use_yaml - type(data_type), dimension(:), allocatable :: data_table !< user-provided data table +type(data_type), dimension(:), allocatable :: data_table !< user-provided data table #else - type(data_type), dimension(max_table) :: data_table !< user-provided data table +type(data_type), dimension(max_table) :: data_table !< user-provided data table #endif - type(data_type) :: default_table - type(override_type), dimension(max_array) :: override_array !< to store processed fields - type(override_type) :: default_array - logical :: debug_data_override - logical :: grid_center_bug = .false. - logical :: reproduce_null_char_bug = .false. !> Flag indicating - !! to reproduce the mpp_io bug where lat/lon_bnd were - !! not read correctly if null characters are present in - !! the netcdf file +type(data_type) :: default_table +type(override_type), dimension(max_array) :: override_array !< to store processed fields +type(override_type) :: default_array +logical :: debug_data_override +logical :: grid_center_bug = .false. +logical :: reproduce_null_char_bug = .false. !> Flag indicating + !! to reproduce the mpp_io bug where lat/lon_bnd were + !! not read correctly if null characters are present in + !! the netcdf file - namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug +namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug - public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & - & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_IMPL_, & - & DATA_OVERRIDE_2D_IMPL_, DATA_OVERRIDE_3D_IMPL_, DATA_OVERRIDE_UG_1D_IMPL_, & - & DATA_OVERRIDE_UG_2D_IMPL_ +public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & + & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_IMPL_, & + & DATA_OVERRIDE_2D_IMPL_, DATA_OVERRIDE_3D_IMPL_, DATA_OVERRIDE_UG_1D_IMPL_, & + & DATA_OVERRIDE_UG_2D_IMPL_ - contains +contains !> @brief Assign default values for default_table, get domain of component models, !! get global grids of component models. @@ -1162,7 +1161,6 @@ subroutine DATA_OVERRIDE_3D_IMPL_(gridname,fieldname_code,data,time,override,dat endif if(PRESENT(override)) override = .true. - end subroutine DATA_OVERRIDE_3D_IMPL_ !> @brief Data override for 1D unstructured grids @@ -1198,7 +1196,6 @@ subroutine DATA_OVERRIDE_UG_1D_IMPL_(gridname,fieldname,data,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) deallocate(data_SG) - end subroutine DATA_OVERRIDE_UG_1D_IMPL_ !> @brief Data override for 2D unstructured grids @@ -1241,7 +1238,4 @@ subroutine DATA_OVERRIDE_UG_2D_IMPL_(gridname,fieldname,data,time,override) data(:,1:nlevel) = data_UG(:,1:nlevel) deallocate(data_SG, data_UG) - end subroutine DATA_OVERRIDE_UG_2D_IMPL_ - -end module DATA_OVERRIDE_IMPL_ diff --git a/data_override/include/data_override_r4.fh b/data_override/include/data_override_r4.fh index a6bce7022a..717a0e0d54 100644 --- a/data_override/include/data_override_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -20,9 +20,6 @@ #undef DATA_OVERRIDE_KIND_ #define DATA_OVERRIDE_KIND_ r4_kind -#undef DATA_OVERRIDE_IMPL_ -#define DATA_OVERRIDE_IMPL_ data_override_r4 - #undef DATA_OVERRIDE_INIT_IMPL_ #define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r4 @@ -53,7 +50,9 @@ #undef DATA_OVERRIDE_UG_2D_IMPL_ #define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r4 +module data_override_r4 #include "data_override.inc" +end module data_override_r4 #undef DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_IMPL_ diff --git a/data_override/include/data_override_r8.fh b/data_override/include/data_override_r8.fh index 61878bd919..70192eed1f 100644 --- a/data_override/include/data_override_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -20,9 +20,6 @@ #undef DATA_OVERRIDE_KIND_ #define DATA_OVERRIDE_KIND_ r8_kind -#undef DATA_OVERRIDE_IMPL_ -#define DATA_OVERRIDE_IMPL_ data_override_r8 - #undef DATA_OVERRIDE_INIT_IMPL_ #define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r8 @@ -53,7 +50,9 @@ #undef DATA_OVERRIDE_UG_2D_IMPL_ #define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r8 +module data_override_r8 #include "data_override.inc" +end module data_override_r8 #undef DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_IMPL_ From a66917f6deaa089a6642157274058bb2d9e70e1b Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 25 Aug 2023 11:42:59 -0400 Subject: [PATCH 19/23] Remove `_IMPL` from macro names `DATA_OVERRIDE_0D_IMPL_` -> `DATA_OVERRIDE_0D_` `DATA_OVERRIDE_2D_IMPL_` -> `DATA_OVERRIDE_2D_` `DATA_OVERRIDE_3D_IMPL_` -> `DATA_OVERRIDE_3D_` `DATA_OVERRIDE_UG_1D_IMPL_` -> `DATA_OVERRIDE_UG_1D_` `DATA_OVERRIDE_UG_2D_IMPL_` -> `DATA_OVERRIDE_UG_2D_` --- data_override/include/data_override.inc | 32 +++++++++++------------ data_override/include/data_override_r4.fh | 31 +++++++++++----------- data_override/include/data_override_r8.fh | 31 +++++++++++----------- 3 files changed, 46 insertions(+), 48 deletions(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index f362072a0a..1786a1326b 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -118,9 +118,9 @@ logical :: reproduce_null_char_bug = .false. namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & - & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_IMPL_, & - & DATA_OVERRIDE_2D_IMPL_, DATA_OVERRIDE_3D_IMPL_, DATA_OVERRIDE_UG_1D_IMPL_, & - & DATA_OVERRIDE_UG_2D_IMPL_ + & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_, & + & DATA_OVERRIDE_2D_, DATA_OVERRIDE_3D_, DATA_OVERRIDE_UG_1D_, & + & DATA_OVERRIDE_UG_2D_ contains @@ -599,7 +599,7 @@ end subroutine get_domainUG !=============================================================================================== !> @brief Routine to perform data override for scalar fields -subroutine DATA_OVERRIDE_0D_IMPL_(gridname,fieldname_code,data,time,override,data_index) +subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_index) character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be !! different from the name in NetCDF data file) @@ -683,10 +683,10 @@ subroutine DATA_OVERRIDE_0D_IMPL_(gridname,fieldname_code,data,time,override,dat if(PRESENT(override)) override = .true. -end subroutine DATA_OVERRIDE_0D_IMPL_ +end subroutine DATA_OVERRIDE_0D_ !> @brief This routine performs data override for 2D fields. -subroutine DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_2D_(gridname,fieldname,data_2D,time,override, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override logical, intent(out), optional :: override !< true if the field has been overriden succesfully @@ -710,15 +710,15 @@ subroutine DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_2D,time,override, is_i allocate(data_3D(size(data_2D,1),size(data_2D,2),1)) data_3D(:,:,1) = data_2D - call DATA_OVERRIDE_3D_IMPL_(gridname,fieldname,data_3D,time,override,data_index=index1,& + call DATA_OVERRIDE_3D_(gridname,fieldname,data_3D,time,override,data_index=index1,& is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in) data_2D(:,:) = data_3D(:,:,1) deallocate(data_3D) -end subroutine DATA_OVERRIDE_2D_IMPL_ +end subroutine DATA_OVERRIDE_2D_ !> @brief This routine performs data override for 3D fields -subroutine DATA_OVERRIDE_3D_IMPL_(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname_code !< field name as used in the model logical, optional, intent(out) :: override !< true if the field has been overriden succesfully @@ -1161,10 +1161,10 @@ subroutine DATA_OVERRIDE_3D_IMPL_(gridname,fieldname_code,data,time,override,dat endif if(PRESENT(override)) override = .true. -end subroutine DATA_OVERRIDE_3D_IMPL_ +end subroutine DATA_OVERRIDE_3D_ !> @brief Data override for 1D unstructured grids -subroutine DATA_OVERRIDE_UG_1D_IMPL_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override real(DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call @@ -1191,15 +1191,15 @@ subroutine DATA_OVERRIDE_UG_1D_IMPL_(gridname,fieldname,data,time,override) call get_domainUG(gridname,UG_domain,comp_domain) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4))) - call DATA_OVERRIDE_2D_IMPL_(gridname,fieldname,data_SG,time,override) + call DATA_OVERRIDE_2D_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) deallocate(data_SG) -end subroutine DATA_OVERRIDE_UG_1D_IMPL_ +end subroutine DATA_OVERRIDE_UG_1D_ !> @brief Data override for 2D unstructured grids -subroutine DATA_OVERRIDE_UG_2D_IMPL_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override real(DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call @@ -1232,10 +1232,10 @@ subroutine DATA_OVERRIDE_UG_2D_IMPL_(gridname,fieldname,data,time,override) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),nlevel_max)) allocate(data_UG(size(data,1), nlevel_max)) data_SG = 0._lkind - call DATA_OVERRIDE_3D_IMPL_(gridname,fieldname,data_SG,time,override) + call DATA_OVERRIDE_3D_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:,:), data_UG(:,:)) data(:,1:nlevel) = data_UG(:,1:nlevel) deallocate(data_SG, data_UG) -end subroutine DATA_OVERRIDE_UG_2D_IMPL_ +end subroutine DATA_OVERRIDE_UG_2D_ diff --git a/data_override/include/data_override_r4.fh b/data_override/include/data_override_r4.fh index 717a0e0d54..99fcecb1da 100644 --- a/data_override/include/data_override_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -35,34 +35,33 @@ #undef DATA_OVERRIDE_UNSET_ICE_ #define DATA_OVERRIDE_UNSET_ICE_ data_override_unset_ice_r4 -#undef DATA_OVERRIDE_0D_IMPL_ -#define DATA_OVERRIDE_0D_IMPL_ data_override_0d_r4 +#undef DATA_OVERRIDE_0D_ +#define DATA_OVERRIDE_0D_ data_override_0d_r4 -#undef DATA_OVERRIDE_2D_IMPL_ -#define DATA_OVERRIDE_2D_IMPL_ data_override_2d_r4 +#undef DATA_OVERRIDE_2D_ +#define DATA_OVERRIDE_2D_ data_override_2d_r4 -#undef DATA_OVERRIDE_3D_IMPL_ -#define DATA_OVERRIDE_3D_IMPL_ data_override_3d_r4 +#undef DATA_OVERRIDE_3D_ +#define DATA_OVERRIDE_3D_ data_override_3d_r4 -#undef DATA_OVERRIDE_UG_1D_IMPL_ -#define DATA_OVERRIDE_UG_1D_IMPL_ data_override_ug_1d_r4 +#undef DATA_OVERRIDE_UG_1D_ +#define DATA_OVERRIDE_UG_1D_ data_override_ug_1d_r4 -#undef DATA_OVERRIDE_UG_2D_IMPL_ -#define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r4 +#undef DATA_OVERRIDE_UG_2D_ +#define DATA_OVERRIDE_UG_2D_ data_override_ug_2d_r4 module data_override_r4 #include "data_override.inc" end module data_override_r4 #undef DATA_OVERRIDE_KIND_ -#undef DATA_OVERRIDE_IMPL_ #undef DATA_OVERRIDE_INIT_IMPL_ #undef DATA_OVERRIDE_UNSET_ATM_ #undef DATA_OVERRIDE_UNSET_OCN_ #undef DATA_OVERRIDE_UNSET_LND_ #undef DATA_OVERRIDE_UNSET_ICE_ -#undef DATA_OVERRIDE_0D_IMPL_ -#undef DATA_OVERRIDE_2D_IMPL_ -#undef DATA_OVERRIDE_3D_IMPL_ -#undef DATA_OVERRIDE_UG_1D_IMPL_ -#undef DATA_OVERRIDE_UG_2D_IMPL_ +#undef DATA_OVERRIDE_0D_ +#undef DATA_OVERRIDE_2D_ +#undef DATA_OVERRIDE_3D_ +#undef DATA_OVERRIDE_UG_1D_ +#undef DATA_OVERRIDE_UG_2D_ diff --git a/data_override/include/data_override_r8.fh b/data_override/include/data_override_r8.fh index 70192eed1f..bcd4ac9831 100644 --- a/data_override/include/data_override_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -35,34 +35,33 @@ #undef DATA_OVERRIDE_UNSET_ICE_ #define DATA_OVERRIDE_UNSET_ICE_ data_override_unset_ice_r8 -#undef DATA_OVERRIDE_0D_IMPL_ -#define DATA_OVERRIDE_0D_IMPL_ data_override_0d_r8 +#undef DATA_OVERRIDE_0D_ +#define DATA_OVERRIDE_0D_ data_override_0d_r8 -#undef DATA_OVERRIDE_2D_IMPL_ -#define DATA_OVERRIDE_2D_IMPL_ data_override_2d_r8 +#undef DATA_OVERRIDE_2D_ +#define DATA_OVERRIDE_2D_ data_override_2d_r8 -#undef DATA_OVERRIDE_3D_IMPL_ -#define DATA_OVERRIDE_3D_IMPL_ data_override_3d_r8 +#undef DATA_OVERRIDE_3D_ +#define DATA_OVERRIDE_3D_ data_override_3d_r8 -#undef DATA_OVERRIDE_UG_1D_IMPL_ -#define DATA_OVERRIDE_UG_1D_IMPL_ data_override_ug_1d_r8 +#undef DATA_OVERRIDE_UG_1D_ +#define DATA_OVERRIDE_UG_1D_ data_override_ug_1d_r8 -#undef DATA_OVERRIDE_UG_2D_IMPL_ -#define DATA_OVERRIDE_UG_2D_IMPL_ data_override_ug_2d_r8 +#undef DATA_OVERRIDE_UG_2D_ +#define DATA_OVERRIDE_UG_2D_ data_override_ug_2d_r8 module data_override_r8 #include "data_override.inc" end module data_override_r8 #undef DATA_OVERRIDE_KIND_ -#undef DATA_OVERRIDE_IMPL_ #undef DATA_OVERRIDE_INIT_IMPL_ #undef DATA_OVERRIDE_UNSET_ATM_ #undef DATA_OVERRIDE_UNSET_OCN_ #undef DATA_OVERRIDE_UNSET_LND_ #undef DATA_OVERRIDE_UNSET_ICE_ -#undef DATA_OVERRIDE_0D_IMPL_ -#undef DATA_OVERRIDE_2D_IMPL_ -#undef DATA_OVERRIDE_3D_IMPL_ -#undef DATA_OVERRIDE_UG_1D_IMPL_ -#undef DATA_OVERRIDE_UG_2D_IMPL_ +#undef DATA_OVERRIDE_0D_ +#undef DATA_OVERRIDE_2D_ +#undef DATA_OVERRIDE_3D_ +#undef DATA_OVERRIDE_UG_1D_ +#undef DATA_OVERRIDE_UG_2D_ From 2b71679810237aca8455745ecacbc998e20f1e37 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 25 Aug 2023 13:26:49 -0400 Subject: [PATCH 20/23] Change kind macro names --- data_override/include/data_override.inc | 56 ++++++++++---------- data_override/include/data_override_r4.fh | 6 +-- data_override/include/data_override_r8.fh | 6 +-- data_override/include/get_grid_version.inc | 4 +- data_override/include/get_grid_version_r4.fh | 6 +-- data_override/include/get_grid_version_r8.fh | 6 +-- 6 files changed, 42 insertions(+), 42 deletions(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 1786a1326b..0a5463efcc 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -57,8 +57,8 @@ type data_type character(len=128) :: fieldname_file !< fieldname used in the netcdf data file character(len=512) :: file_name !< name of netCDF data file character(len=128) :: interpol_method !< interpolation method (default "bilinear") - real(DATA_OVERRIDE_KIND_) :: factor !< For unit conversion, default=1, see OVERVIEW above - real(DATA_OVERRIDE_KIND_) :: lon_start, lon_end, lat_start, lat_end + 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 end type data_type @@ -72,15 +72,15 @@ type override_type integer :: dims(4) !< dimensions(x,y,z,t) of the field in filename integer :: comp_domain(4) !< istart,iend,jstart,jend for compute domain integer :: numthreads - real(DATA_OVERRIDE_KIND_), allocatable :: lon_in(:) - real(DATA_OVERRIDE_KIND_), allocatable :: lat_in(:) + real(FMS_DATA_OVERRIDE_KIND_), allocatable :: lon_in(:) + real(FMS_DATA_OVERRIDE_KIND_), allocatable :: lat_in(:) logical, allocatable :: need_compute(:) integer :: numwindows integer :: window_size(2) integer :: is_src, ie_src, js_src, je_src end type override_type -integer, parameter :: lkind = DATA_OVERRIDE_KIND_ +integer, parameter :: lkind = FMS_DATA_OVERRIDE_KIND_ integer, parameter :: max_table=100, max_array=100 integer :: table_size !< actual size of data table @@ -89,14 +89,14 @@ logical :: module_is_initialized = .FALSE. type(domain2D) :: ocn_domain,atm_domain,lnd_domain, ice_domain type(domainUG) :: lnd_domainUG -real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn -real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm -real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice -real(DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd -real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ocn, max_glo_lon_ocn -real(DATA_OVERRIDE_KIND_) :: min_glo_lon_atm, max_glo_lon_atm -real(DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd -real(DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice +real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ocn, lat_local_ocn +real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_atm, lat_local_atm +real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_ice, lat_local_ice +real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), target, allocatable :: lon_local_lnd, lat_local_lnd +real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_ocn, max_glo_lon_ocn +real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_atm, max_glo_lon_atm +real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd +real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice integer :: num_fields = 0 !< number of fields in override_array already processed #ifdef use_yaml @@ -605,7 +605,7 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind !! different from the name in NetCDF data file) logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time - real(DATA_OVERRIDE_KIND_), intent(out) :: data !< output data array returned by this call + real(FMS_DATA_OVERRIDE_KIND_), intent(out) :: data !< output data array returned by this call integer, intent(in), optional :: data_index character(len=512) :: filename !< file containing source data @@ -614,7 +614,7 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind integer :: id_time !< index for time interp in override array integer :: curr_position !< position of the field currently processed in override_array integer :: i - real(DATA_OVERRIDE_KIND_) :: factor + real(FMS_DATA_OVERRIDE_KIND_) :: factor if(.not.module_is_initialized) & call mpp_error(FATAL,'Error: need to call data_override_init first') @@ -691,9 +691,9 @@ subroutine DATA_OVERRIDE_2D_(gridname,fieldname,data_2D,time,override, is_in, ie character(len=*), intent(in) :: fieldname !< field to override logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< model time - real(DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data_2D !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data_2D !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in - real(DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_3D + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_3D integer :: index1 integer :: i @@ -724,7 +724,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind logical, optional, intent(out) :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time integer, optional, intent(in) :: data_index - real(DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: data !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in logical, dimension(:,:,:), allocatable :: mask_out @@ -737,15 +737,15 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind integer :: id_time !< index for time interp in override array integer :: axis_sizes(4) character(len=32) :: axis_names(4) - real(DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells - real(DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells - real(DATA_OVERRIDE_KIND_), dimension(:), allocatable :: lon_tmp, lat_tmp + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells + real(FMS_DATA_OVERRIDE_KIND_), dimension(:), allocatable :: lon_tmp, lat_tmp logical :: data_file_is_2D = .false. !< data in netCDF file is 2D logical :: ongrid, use_comp_domain type(domain2D) :: domain integer :: curr_position !< position of the field currently processed in override_array - real(DATA_OVERRIDE_KIND_) :: factor + real(FMS_DATA_OVERRIDE_KIND_) :: factor integer, dimension(4) :: comp_domain = 0 !< istart,iend,jstart,jend for compute domain integer :: nxd, nyd, nxc, nyc, nwindows integer :: nwindows_x, ipos, jpos, window_size(2) @@ -753,7 +753,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind integer :: isw, iew, jsw, jew integer :: omp_get_num_threads, window_id logical :: need_compute - real(DATA_OVERRIDE_KIND_) :: lat_min, lat_max + real(FMS_DATA_OVERRIDE_KIND_) :: lat_min, lat_max integer :: is_src, ie_src, js_src, je_src logical :: exists type(FmsNetcdfFile_t) :: fileobj @@ -1167,11 +1167,11 @@ end subroutine DATA_OVERRIDE_3D_ subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars - real(DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_SG + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_SG type(domainUG) :: UG_domain integer :: index1 integer :: i @@ -1202,12 +1202,12 @@ end subroutine DATA_OVERRIDE_UG_1D_ subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars - real(DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_SG - real(DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_UG + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), allocatable :: data_SG + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), allocatable :: data_UG type(domainUG) :: UG_domain integer :: index1 integer :: i, nlevel, nlevel_max diff --git a/data_override/include/data_override_r4.fh b/data_override/include/data_override_r4.fh index 99fcecb1da..45eb43b4ce 100644 --- a/data_override/include/data_override_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** -#undef DATA_OVERRIDE_KIND_ -#define DATA_OVERRIDE_KIND_ r4_kind +#undef FMS_DATA_OVERRIDE_KIND_ +#define FMS_DATA_OVERRIDE_KIND_ r4_kind #undef DATA_OVERRIDE_INIT_IMPL_ #define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r4 @@ -54,7 +54,7 @@ module data_override_r4 #include "data_override.inc" end module data_override_r4 -#undef DATA_OVERRIDE_KIND_ +#undef FMS_DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_INIT_IMPL_ #undef DATA_OVERRIDE_UNSET_ATM_ #undef DATA_OVERRIDE_UNSET_OCN_ diff --git a/data_override/include/data_override_r8.fh b/data_override/include/data_override_r8.fh index bcd4ac9831..efe3df45ad 100644 --- a/data_override/include/data_override_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** -#undef DATA_OVERRIDE_KIND_ -#define DATA_OVERRIDE_KIND_ r8_kind +#undef FMS_DATA_OVERRIDE_KIND_ +#define FMS_DATA_OVERRIDE_KIND_ r8_kind #undef DATA_OVERRIDE_INIT_IMPL_ #define DATA_OVERRIDE_INIT_IMPL_ data_override_init_r8 @@ -54,7 +54,7 @@ module data_override_r8 #include "data_override.inc" end module data_override_r8 -#undef DATA_OVERRIDE_KIND_ +#undef FMS_DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_INIT_IMPL_ #undef DATA_OVERRIDE_UNSET_ATM_ #undef DATA_OVERRIDE_UNSET_OCN_ diff --git a/data_override/include/get_grid_version.inc b/data_override/include/get_grid_version.inc index e2d7a6bd15..fd65588e46 100644 --- a/data_override/include/get_grid_version.inc +++ b/data_override/include/get_grid_version.inc @@ -19,7 +19,7 @@ !> Get global lon and lat of three model (target) grids, with a given file name subroutine GET_GRID_VERSION_1_(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon) - integer, parameter :: lkind = GET_GRID_VERSION_KIND_ + integer, parameter :: lkind = FMS_GET_GRID_VERSION_KIND_ character(len=*), intent(in) :: grid_file !< name of grid file character(len=*), intent(in) :: mod_name !< module name @@ -144,7 +144,7 @@ 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) - integer, parameter :: lkind = GET_GRID_VERSION_KIND_ + integer, parameter :: lkind = FMS_GET_GRID_VERSION_KIND_ type(FmsNetcdfFile_t), intent(in) :: fileobj !< file object for grid file character(len=*), intent(in) :: mod_name !< module name diff --git a/data_override/include/get_grid_version_r4.fh b/data_override/include/get_grid_version_r4.fh index acea79cb08..03ad66a8b0 100644 --- a/data_override/include/get_grid_version_r4.fh +++ b/data_override/include/get_grid_version_r4.fh @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** -#undef GET_GRID_VERSION_KIND_ -#define GET_GRID_VERSION_KIND_ r4_kind +#undef FMS_GET_GRID_VERSION_KIND_ +#define FMS_GET_GRID_VERSION_KIND_ r4_kind #undef GET_GRID_VERSION_1_ #define GET_GRID_VERSION_1_ get_grid_version_1_r4 @@ -28,6 +28,6 @@ #include "get_grid_version.inc" -#undef GET_GRID_VERSION_KIND_ +#undef FMS_GET_GRID_VERSION_KIND_ #undef GET_GRID_VERSION_1_ #undef GET_GRID_VERSION_2_ diff --git a/data_override/include/get_grid_version_r8.fh b/data_override/include/get_grid_version_r8.fh index 0d8ff56df5..40a2c510b6 100644 --- a/data_override/include/get_grid_version_r8.fh +++ b/data_override/include/get_grid_version_r8.fh @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** -#undef GET_GRID_VERSION_KIND_ -#define GET_GRID_VERSION_KIND_ r8_kind +#undef FMS_GET_GRID_VERSION_KIND_ +#define FMS_GET_GRID_VERSION_KIND_ r8_kind #undef GET_GRID_VERSION_1_ #define GET_GRID_VERSION_1_ get_grid_version_1_r8 @@ -28,6 +28,6 @@ #include "get_grid_version.inc" -#undef GET_GRID_VERSION_KIND_ +#undef FMS_GET_GRID_VERSION_KIND_ #undef GET_GRID_VERSION_1_ #undef GET_GRID_VERSION_2_ From ca0d5ab2187bcadcfc111a41ebfccf84e96e6cdc Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 29 Aug 2023 09:29:21 -0400 Subject: [PATCH 21/23] Remove duplicate line in Makefile.am --- data_override/Makefile.am | 1 - 1 file changed, 1 deletion(-) diff --git a/data_override/Makefile.am b/data_override/Makefile.am index 8f7856a83d..718b127ec4 100644 --- a/data_override/Makefile.am +++ b/data_override/Makefile.am @@ -42,7 +42,6 @@ libdata_override_la_SOURCES = \ # Some mods are dependent on other mods in this dir. data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) -data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ From d93c3cd974c362adf49fcd946ebf1b2856a5e4b4 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 30 Aug 2023 09:54:10 -0400 Subject: [PATCH 22/23] Add comments and move `module`/`module end` statements Comments have been added to the tops of `data_override.F90` and `data_override.inc`. The `module` and `module end` statements have been moved from the .fh files to `data_override.F90`. --- data_override/data_override.F90 | 9 +++++++++ data_override/include/data_override.inc | 4 ++++ data_override/include/data_override_r4.fh | 2 -- data_override/include/data_override_r8.fh | 2 -- 4 files changed, 13 insertions(+), 4 deletions(-) diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index ff79e35e45..8ea6b1a6d1 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -17,8 +17,17 @@ !* License along with FMS. If not, see . !*********************************************************************** +! data_override_r4 and data_override_r8 are not intended to be used directly - +! they should be used through the data_override_mod API. The body of +! data_override_r4 and data_override_r8 is contained in data_override.inc. + +module data_override_r4 #include "data_override_r4.fh" +end module data_override_r4 + +module data_override_r8 #include "data_override_r8.fh" +end module data_override_r8 !> @defgroup data_override_mod data_override_mod !> @ingroup data_override diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 0a5463efcc..1cf94b49cc 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -17,6 +17,10 @@ !* License along with FMS. If not, see . !*********************************************************************** +! This file contains the body of the data_override_r4 and data_override_r8 +! 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 yaml_parser_mod use constants_mod, only: DEG_TO_RAD diff --git a/data_override/include/data_override_r4.fh b/data_override/include/data_override_r4.fh index 45eb43b4ce..c61fc3d853 100644 --- a/data_override/include/data_override_r4.fh +++ b/data_override/include/data_override_r4.fh @@ -50,9 +50,7 @@ #undef DATA_OVERRIDE_UG_2D_ #define DATA_OVERRIDE_UG_2D_ data_override_ug_2d_r4 -module data_override_r4 #include "data_override.inc" -end module data_override_r4 #undef FMS_DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_INIT_IMPL_ diff --git a/data_override/include/data_override_r8.fh b/data_override/include/data_override_r8.fh index efe3df45ad..1d7cfc9a97 100644 --- a/data_override/include/data_override_r8.fh +++ b/data_override/include/data_override_r8.fh @@ -50,9 +50,7 @@ #undef DATA_OVERRIDE_UG_2D_ #define DATA_OVERRIDE_UG_2D_ data_override_ug_2d_r8 -module data_override_r8 #include "data_override.inc" -end module data_override_r8 #undef FMS_DATA_OVERRIDE_KIND_ #undef DATA_OVERRIDE_INIT_IMPL_ From da7da2ce85ad07f7d1b40702e039a647ca63f4d7 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 30 Aug 2023 11:27:50 -0400 Subject: [PATCH 23/23] Eliminate implicit kinds and typecasts --- data_override/include/data_override.inc | 4 ++-- test_fms/data_override/test_get_grid_v1.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 1cf94b49cc..663d2b0fcf 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -907,8 +907,8 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind call mpp_error(FATAL,'data_override: file '//trim(filename)//' is not opened in time_interp_external') end if ! convert lon_in and lat_in from deg to radian - override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * DEG_TO_RAD - override_array(curr_position)%lat_in = override_array(curr_position)%lat_in * DEG_TO_RAD + override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * real(DEG_TO_RAD, lkind) + override_array(curr_position)%lat_in = override_array(curr_position)%lat_in * real(DEG_TO_RAD, lkind) !--- find the region of the source grid that cover the local model grid. !--- currently we only find the index range for j-direction because diff --git a/test_fms/data_override/test_get_grid_v1.F90 b/test_fms/data_override/test_get_grid_v1.F90 index 2fa6a2c45b..d1c1fa755f 100644 --- a/test_fms/data_override/test_get_grid_v1.F90 +++ b/test_fms/data_override/test_get_grid_v1.F90 @@ -131,11 +131,11 @@ program test_get_grid_v1 min_lon, max_lon) !< Error checking: -if (lon(1,1) .ne. sum(lon_vert_in)/4*real(DEG_TO_RAD, lkind) ) then +if (lon(1,1) .ne. sum(lon_vert_in)/4._lkind * real(DEG_TO_RAD, lkind) ) then call mpp_error(FATAL,'test_get_grid_v1: ocn, new grid, lon is not the expected result') endif -if (lat(1,1) .ne. sum(lat_vert_in)/4*real(DEG_TO_RAD, lkind) ) then +if (lat(1,1) .ne. sum(lat_vert_in)/4._lkind * real(DEG_TO_RAD, lkind) ) then call mpp_error(FATAL,'test_get_grid_v1: ocn, new grid, lat is not the expected result') endif