From 1a309f49583b8434eebf58c88adbed6738c23506 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 4 Aug 2023 15:35:25 -0400 Subject: [PATCH] working compile with type changes --- coupler/Makefile.am | 5 +- coupler/atmos_ocean_fluxes.F90 | 1 + coupler/coupler_types.F90 | 640 ++--- coupler/include/atmos_ocean_fluxes.inc | 1174 ---------- coupler/include/coupler_types.inc | 2962 +----------------------- coupler/include/coupler_types_r4.fh | 50 + coupler/include/coupler_types_r8.fh | 50 + coupler/include/ensemble_manager.inc | 423 ---- libFMS.F90 | 18 +- 9 files changed, 343 insertions(+), 4980 deletions(-) delete mode 100644 coupler/include/atmos_ocean_fluxes.inc create mode 100644 coupler/include/coupler_types_r4.fh create mode 100644 coupler/include/coupler_types_r8.fh delete mode 100644 coupler/include/ensemble_manager.inc diff --git a/coupler/Makefile.am b/coupler/Makefile.am index 30caa6aba7..7a6c42db30 100644 --- a/coupler/Makefile.am +++ b/coupler/Makefile.am @@ -33,7 +33,10 @@ noinst_LTLIBRARIES = libcoupler.la libcoupler_la_SOURCES = \ coupler_types.F90 \ ensemble_manager.F90 \ - atmos_ocean_fluxes.F90 + atmos_ocean_fluxes.F90 \ + include/coupler_types.inc \ + include/coupler_types_r4.fh \ + include/coupler_types_r8.fh # Some mods are dependant on other mods in this dir. atmos_ocean_fluxes_mod.$(FC_MODEXT): coupler_types_mod.$(FC_MODEXT) diff --git a/coupler/atmos_ocean_fluxes.F90 b/coupler/atmos_ocean_fluxes.F90 index 6e530abfaf..585ce1c02a 100644 --- a/coupler/atmos_ocean_fluxes.F90 +++ b/coupler/atmos_ocean_fluxes.F90 @@ -64,6 +64,7 @@ module atmos_ocean_fluxes_mod use fm_util_mod, only: fm_util_check_for_bad_fields, fm_util_get_string use fm_util_mod, only: fm_util_get_real_array, fm_util_get_real, fm_util_get_integer use fm_util_mod, only: fm_util_get_logical, fm_util_get_logical_array + use platform_mod, only: r4_kind, r8_kind implicit none private diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 3e46f81ec8..e1d38ec35b 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -67,13 +67,65 @@ module coupler_types_mod !> @} - type, private :: coupler_3d_reals_r8_type + !! mixed precision methodology for the encapsulated types: + !! each level is an array of the type within the previous type + !! + !! bc (coupler_nd_real8_field) -> field (coupler_nd_real8_values) + !! coupler_nd_bc_type < + !! bc_r4 (coupler_nd_real4_field) -> field (coupler_nd_real4_values) + !! + !! This allows for minimal changes to other codes since these real values are usually accessed directly. + !! + !! Theres no real constructor/initializer for these types (oddly). + !! Arrays (values + field) are typically directly allocated and then 'spawn' can be used to create a new type from a previously allocated 'template' type + !! ie. allocate(ex_gas_fields_ice%bc(n)%field(m)%values) + + !> Coupler data for 3D values + !> @ingroup coupler_types_mod + type, public :: coupler_3d_real8_values_type + character(len=48) :: name = ' ' !< The diagnostic name for this array + logical :: mean = .true. !< mean + logical :: override = .false. !< override + integer :: id_diag = 0 !< The diagnostic id for this array + character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array + character(len=128) :: units = ' ' !< The units for this array + integer :: id_rest = 0 !< The id of this array in the restart field + logical :: may_init = .true. !< If true, there is an internal method + !! that can be used to initialize this field + !! if it can not be read from a restart file + real(r8_kind), pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the + !! array of values for this field; this + !! should be changed to allocatable + end type coupler_3d_real8_values_type - end type coupler_3d_reals_r8_type + !> Coupler data for 3D fields + !> @ingroup coupler_types_mod + type, public :: coupler_3d_real8_field_type + character(len=48) :: name = ' ' !< name + integer :: num_fields = 0 !< num_fields + type(coupler_3d_real8_values_type), pointer, dimension(:) :: field => NULL() !< field + character(len=128) :: flux_type = ' ' !< flux_type + character(len=128) :: implementation = ' ' !< implementation + logical, pointer, dimension(:) :: flag => NULL() !< flag + integer :: atm_tr_index = 0 !< atm_tr_index + character(len=128) :: ice_restart_file = ' ' !< ice_restart_file + character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io + type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type + !! that is used for this field. +#endif + type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type + !! That is used for this field + logical :: use_atm_pressure !< use_atm_pressure + logical :: use_10m_wind_speed !< use_10m_wind_speed + logical :: pass_through_ice !< pass_through_ice + real(r8_kind), pointer, dimension(:) :: param => NULL() !< param + real(r8_kind) :: mol_wt = 0.0 !< mol_wt + end type coupler_3d_real8_field_type !> Coupler data for 3D values !> @ingroup coupler_types_mod - type, public :: coupler_3d_values_type + type, public :: coupler_3d_real4_values_type character(len=48) :: name = ' ' !< The diagnostic name for this array logical :: mean = .true. !< mean logical :: override = .false. !< override @@ -84,17 +136,17 @@ module coupler_types_mod logical :: may_init = .true. !< If true, there is an internal method !! that can be used to initialize this field !! if it can not be read from a restart file - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the + real(r4_kind), pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the !! array of values for this field; this !! should be changed to allocatable - end type coupler_3d_values_type + end type coupler_3d_real4_values_type !> Coupler data for 3D fields !> @ingroup coupler_types_mod - type, public :: coupler_3d_field_type + type, public :: coupler_3d_real4_field_type character(len=48) :: name = ' ' !< name integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field + type(coupler_3d_real4_values_type), pointer, dimension(:) :: field => NULL() !< field character(len=128) :: flux_type = ' ' !< flux_type character(len=128) :: implementation = ' ' !< implementation logical, pointer, dimension(:) :: flag => NULL() !< flag @@ -110,16 +162,17 @@ module coupler_types_mod logical :: use_atm_pressure !< use_atm_pressure logical :: use_10m_wind_speed !< use_10m_wind_speed logical :: pass_through_ice !< pass_through_ice - real, pointer, dimension(:) :: param => NULL() !< param - real :: mol_wt = 0.0 !< mol_wt - end type coupler_3d_field_type + real(r4_kind), pointer, dimension(:) :: param => NULL() !< param + real(r4_kind) :: mol_wt = 0.0 !< mol_wt + end type coupler_3d_real4_field_type !> Coupler data for 3D boundary conditions !> @ingroup coupler_types_mod type, public :: coupler_3d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields + type(coupler_3d_real8_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! TODO above should be renamed eventually to indicate kind=8 + type(coupler_3d_real4_field_type), dimension(:), pointer :: bc_r4 => NULL() !< A pointer to the array of boundary logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -129,9 +182,9 @@ module coupler_types_mod !> Coupler data for 2D values !> @ingroup coupler_types_mod - type, public :: coupler_2d_values_type + type, public :: coupler_2d_real8_values_type character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the + real(r8_kind), pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the !! array of values for this field; this !! should be changed to allocatable logical :: mean = .true. !< mean @@ -143,17 +196,17 @@ module coupler_types_mod logical :: may_init = .true. !< If true, there is an internal method !! that can be used to initialize this field !! if it can not be read from a restart file - end type coupler_2d_values_type + end type coupler_2d_real8_values_type !> Coupler data for 2D fields !> @ingroup coupler_types_mod - type, public :: coupler_2d_field_type + type, public :: coupler_2d_real8_field_type character(len=48) :: name = ' ' !< name integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field + type(coupler_2d_real8_values_type), pointer, dimension(:) :: field => NULL() !< field character(len=128) :: flux_type = ' ' !< flux_type character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param + real(r8_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file @@ -167,14 +220,59 @@ module coupler_types_mod logical :: use_atm_pressure !< use_atm_pressure logical :: use_10m_wind_speed !< use_10m_wind_speed logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt - end type coupler_2d_field_type + real(r8_kind) :: mol_wt = 0.0 !< mol_wt + end type coupler_2d_real8_field_type + + !> Coupler data for 2D values + !> @ingroup coupler_types_mod + type, public :: coupler_2d_real4_values_type + character(len=44) :: name = ' ' !< The diagnostic name for this array + real(r4_kind), pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the + !! array of values for this field; this + !! should be changed to allocatable + logical :: mean = .true. !< mean + logical :: override = .false. !< override + integer :: id_diag = 0 !< The diagnostic id for this array + character(len=124) :: long_name = ' ' !< The diagnostic long_name for this array + character(len=124) :: units = ' ' !< The units for this array + integer :: id_rest = 0 !< The id of this array in the restart field + logical :: may_init = .true. !< If true, there is an internal method + !! that can be used to initialize this field + !! if it can not be read from a restart file + end type coupler_2d_real4_values_type + + !> Coupler data for 2D fields + !> @ingroup coupler_types_mod + type, public :: coupler_2d_real4_field_type + character(len=44) :: name = ' ' !< name + integer :: num_fields = 0 !< num_fields + type(coupler_2d_real4_values_type), pointer, dimension(:) :: field => NULL() !< field + character(len=124) :: flux_type = ' ' !< flux_type + character(len=124) :: implementation = ' ' !< implementation + real(r4_kind), pointer, dimension(:) :: param => NULL() !< param + logical, pointer, dimension(:) :: flag => NULL() !< flag + integer :: atm_tr_index = 0 !< atm_tr_index + character(len=124) :: ice_restart_file = ' ' !< ice_restart_file + character(len=124) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io + type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type + !! that is used for this field. +#endif + type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type + !! That is used for this field + logical :: use_atm_pressure !< use_atm_pressure + logical :: use_10m_wind_speed !< use_10m_wind_speed + logical :: pass_through_ice !< pass_through_ice + real(r4_kind) :: mol_wt = 0.0 !< mol_wt + end type coupler_2d_real4_field_type !> Coupler data for 2D boundary conditions !> @ingroup coupler_types_mod type, public :: coupler_2d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + type(coupler_2d_real8_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields + type(coupler_2d_real4_field_type), dimension(:), pointer :: bc_r4 => NULL() !< A pointer to the array of boundary !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type @@ -183,9 +281,9 @@ module coupler_types_mod !> Coupler data for 1D values !> @ingroup coupler_types_mod - type, public :: coupler_1d_values_type + type, public :: coupler_1d_real8_values_type character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values + real(r8_kind), pointer, dimension(:) :: values => NULL() !< The pointer to the array of values logical :: mean = .true. !< mean logical :: override = .false. !< override integer :: id_diag = 0 !< The diagnostic id for this array @@ -194,21 +292,20 @@ module coupler_types_mod logical :: may_init = .true. !< If true, there is an internal method !! that can be used to initialize this field !! if it can not be read from a restart file - end type coupler_1d_values_type + end type coupler_1d_real8_values_type !> Coupler data for 1D fields !> @ingroup coupler_types_mod - type, public :: coupler_1d_field_type + type, public :: coupler_1d_real8_field_type character(len=48) :: name = ' ' !< name integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field + type(coupler_1d_real8_values_type), pointer, dimension(:) :: field => NULL() !< field character(len=128) :: flux_type = ' ' !< flux_type character(len=128) :: implementation = ' ' !< implementation !> precision has been explicitly defined !! to be r8_kind during mixedmode update to field_manager !! this explicit definition can be removed during the coupler update and be made into FMS_CP_KIND_ real(r8_kind), pointer, dimension(:) :: param => NULL() !< param - real(r4_kind), pointer, dimension(:) :: param => NULL() !< param logical, pointer, dimension(:) :: flag => NULL() !< flag integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file @@ -221,13 +318,56 @@ module coupler_types_mod !! this explicit definition can be removed during the coupler update and be made into FMS_CP_KIND_ real(r8_kind) :: mol_wt = 0.0 !< mol_wt - end type coupler_1d_field_type + end type coupler_1d_real8_field_type + + !> Coupler data for 1D values + !> @ingroup coupler_types_mod + type, public :: coupler_1d_real4_values_type + character(len=48) :: name = ' ' !< The diagnostic name for this array + real(r4_kind), pointer, dimension(:) :: values => NULL() !< The pointer to the array of values + logical :: mean = .true. !< mean + logical :: override = .false. !< override + integer :: id_diag = 0 !< The diagnostic id for this array + character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array + character(len=128) :: units = ' ' !< The units for this array + logical :: may_init = .true. !< If true, there is an internal method + !! that can be used to initialize this field + !! if it can not be read from a restart file + end type coupler_1d_real4_values_type + + !> Coupler data for 1D fields + !> @ingroup coupler_types_mod + type, public :: coupler_1d_real4_field_type + character(len=48) :: name = ' ' !< name + integer :: num_fields = 0 !< num_fields + type(coupler_1d_real4_values_type), pointer, dimension(:) :: field => NULL() !< field + character(len=128) :: flux_type = ' ' !< flux_type + character(len=128) :: implementation = ' ' !< implementation + !> precision has been explicitly defined + !! to be r8_kind during mixedmode update to field_manager + !! this explicit definition can be removed during the coupler update and be made into FMS_CP_KIND_ + real(r4_kind), pointer, dimension(:) :: param => NULL() !< param + logical, pointer, dimension(:) :: flag => NULL() !< flag + integer :: atm_tr_index = 0 !< atm_tr_index + character(len=128) :: ice_restart_file = ' ' !< ice_restart_file + character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file + logical :: use_atm_pressure !< use_atm_pressure + logical :: use_10m_wind_speed !< use_10m_wind_speed + logical :: pass_through_ice !< pass_through_ice + !> precision has been explicitly defined + !! to be r8_kind during mixedmode update to field_manager + !! this explicit definition can be removed during the coupler update and be made into FMS_CP_KIND_ + real(r4_kind) :: mol_wt = 0.0 !< mol_wt + + end type coupler_1d_real4_field_type !> Coupler data for 1D boundary conditions !> @ingroup coupler_types_mod type, public :: coupler_1d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + type(coupler_1d_real8_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields + type(coupler_1d_real4_field_type), dimension(:), pointer :: bc_r4 => NULL() !< A pointer to the array of boundary !! condition fields logical :: set = .false. !< If true, this type has been initialized end type coupler_1d_bc_type @@ -287,7 +427,8 @@ module coupler_types_mod !> This is the interface to rescale the field data in a coupler_bc_type. !> @ingroup coupler_types_mod interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d + module procedure CT_rescale_data_2d_r4, CT_rescale_data_3d_r4 + module procedure CT_rescale_data_2d_r8, CT_rescale_data_3d_r8 end interface coupler_type_rescale_data !> This is the interface to increment the field data from one coupler_bc_type @@ -295,13 +436,16 @@ module coupler_types_mod !! decomposition, but a 2d type may be incremented by a 2d or 3d type !> @ingroup coupler_types_mod interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d + module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d + module procedure CT_increment_data_2d_3d_r4, CT_increment_data_2d_3d_r8 end interface coupler_type_increment_data !> This is the interface to extract a field in a coupler_bc_type into an array. !> @ingroup coupler_types_mod interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d + module procedure CT_extract_data_2d_r4, CT_extract_data_2d_r8 + module procedure CT_extract_data_3d_r4, CT_extract_data_3d_r8 + module procedure CT_extract_data_3d_2d_r4, CT_extract_data_3d_2d_r8 end interface coupler_type_extract_data !> This is the interface to set a field in a coupler_bc_type from an array. @@ -914,6 +1058,7 @@ subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) & '==>Error from coupler_types_mod (CT_spawn_2d_3d):' character(len=400) :: error_msg integer :: m, n + logical :: is_kind_8 if (present(as_needed)) then if (as_needed) then @@ -926,6 +1071,8 @@ subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) if (.not.var_in%set)& & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') + is_kind_8 = associated(var_in%bc) + var%num_bcs = var_in%num_bcs var%set = .true. @@ -2225,432 +2372,6 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi enddo end subroutine CT_increment_data_2d_3d - !> @brief Extract a 2d field from a coupler_2d_bc_type - !! - !! Extract a single 2-d field from a coupler_2d_bc_type into a two-dimensional array. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive j-direction halo size for the input structure." - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" - !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" - subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out,& - & scale_factor, halo_size, idim, jdim) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_extract_data_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - scale = 1.0 - if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',& - & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an i-direction computational domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & (1+idim(4)-idim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & size(array_out,1), ' does not match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',& - & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an j-direction computational domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & size(array_out,2), ' does not match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - do j=var_in%jsc-halo,var_in%jec+halo - do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) - enddo - enddo - end subroutine CT_extract_data_2d - - !> @brief Extract a single k-level of a 3d field from a coupler_3d_bc_type - !! - !! Extract a single k-level of a 3-d field from a coupler_3d_bc_type into a two-dimensional array. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive j-direction halo size for the input structure." - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" - !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" - !! @throw FATAL, "The extracted k-index of 'k' is outside of the valid range of 'ks' to 'ke'" - subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out,& - & scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - integer, intent(in) :: k_in !< The k-index to extract - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, halo, i_off, j_off - - if (bc_index <= 0) then - array_out(:,:) = 0.0 - return - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - scale = 1.0 - if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',& - & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an i-direction computational domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & (1+idim(4)-idim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & size(array_out,1), ' does not match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',& - & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an j-direction computational domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & size(array_out,2), ' does not match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then - write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in,& - & ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke - call mpp_error(FATAL, trim(error_msg)) - endif - - do j=var_in%jsc-halo,var_in%jec+halo - do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) - enddo - enddo - end subroutine CT_extract_data_3d_2d - - !> @brief Extract single 3d field from a coupler_3d_bc_type - !! - !! Extract a single 3-d field from a coupler_3d_bc_type into a three-dimensional array. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive j-direction halo size for the input structure." - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'" - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" - !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" - !! @throw FATAL, "The target array with k-dimension size 'n' does not match the data of size 'd'" - subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out,& - & scale_factor, halo_size, idim, jdim) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract - integer, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size - !! must match the size of the data being copied - !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of - !! the first dimension of the output array - !! in a non-decreasing list - integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension of the output array - !! in a non-decreasing list - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_extract_data_3d):' - character(len=400) :: error_msg - - real :: scale - integer :: i, j, k, halo, i_off, j_off, k_off - - if (bc_index <= 0) then - array_out(:,:,:) = 0.0 - return - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - scale = 1.0 - if (present(scale_factor)) scale = scale_factor - - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the input structure.") - - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, trim(error_header)//" bc_index exceeds var_in%num_bcs.") - if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, trim(error_header)//" field_index exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - - ! Do error checking on the i-dimension and determine the array offsets. - if (present(idim)) then - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,1) /= (1+idim(4)-idim(1))) then - write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',& - & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an i-direction computational domain size mismatch.") - if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive i-direction halo size for the output array.") - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & (1+idim(4)-idim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - - i_off = (1-idim(1)) + (idim(2)-var_in%isc) - else - if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then - write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',& - & size(array_out,1), ' does not match the data of size ',& - & (2*halo + 1 + var_in%iec - var_in%isc) - call mpp_error(FATAL, trim(error_msg)) - endif - i_off = 1 - (var_in%isc-halo) - endif - - ! Do error checking on the j-dimension and determine the array offsets. - if (present(jdim)) then - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then - write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',& - & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2) - call mpp_error(FATAL, trim(error_msg)) - endif - if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))& - & call mpp_error(FATAL, trim(error_header)//" There is an j-direction computational domain size mismatch.") - if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))& - & call mpp_error(FATAL, trim(error_header)//" Excessive j-direction halo size for the output array.") - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - - j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc) - else - if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then - write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',& - & size(array_out,2), ' does not match the data of size ',& - & (2*halo + 1 + var_in%jec - var_in%jsc) - call mpp_error(FATAL, trim(error_msg)) - endif - j_off = 1 - (var_in%jsc-halo) - endif - - if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then - write (error_msg, *) trim(error_header), ' The target array with k-dimension size ',& - & size(array_out,3), ' does not match the data of size ',& - & (1 + var_in%ke - var_in%ks) - call mpp_error(FATAL, trim(error_msg)) - endif - k_off = 1 - var_in%ks - - do k=var_in%ks,var_in%ke - do j=var_in%jsc-halo,var_in%jec+halo - do i=var_in%isc-halo,var_in%iec+halo - array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k) - enddo - enddo - enddo - end subroutine CT_extract_data_3d - !> @brief Set single 2d field in coupler_3d_bc_type !! !! Set a single 2-d field in a coupler_3d_bc_type from a two-dimensional array. @@ -3761,6 +3482,9 @@ subroutine CT_destructor_3d(var) var%set = .false. end subroutine CT_destructor_3d +#include "include/coupler_types_r4.fh" +#include "include/coupler_types_r8.fh" + !! @brief Register the fields in a coupler_2d_bc_type to be saved in restart files !! !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files diff --git a/coupler/include/atmos_ocean_fluxes.inc b/coupler/include/atmos_ocean_fluxes.inc deleted file mode 100644 index 24c40c89fb..0000000000 --- a/coupler/include/atmos_ocean_fluxes.inc +++ /dev/null @@ -1,1174 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup atmos_ocean_fluxes_mod atmos_ocean_fluxes_mod -!> @ingroup coupler - -!> @addtogroup atmos_ocean_fluxes_mod -!> @{ - - !> @brief Set the values for a coupler flux - !! @return its index (0 on error) - !! @throw FATAL, "Empty name given" - !! Name is empty - !! @throw FATAL, "Could not get coupler flux" - !! coupler_index is less than 1 - !! @throw FATAL, "Could not set coupler flux" - !! coupler_index is less than 1 - !! @throw FATAL, "Could not get the current list" - !! Current list is empty - !! @throw FATAL, "Could not change to the new list" - !! fm_change_list(coupler_list) returns false - !! @throw FATAL, "Blank flux_type given" - !! flux_type or implementation is empty - !! @throw FATAL, "Undefined flux_type given from field_table" - !! flux_type does not equal flux_type_test - !! @throw FATAL, "Undefined flux_type given as argument to the subroutine" - !! flux_type does not equal flux_type_test - !! @throw FATAL, "Undefined flux_type/implementation (implementation given from field_table)" - !! flux_type does not equal flux_type_test - !! @throw FATAL, "Undefined flux_type/implementation (flux_type given from field_table)" - !! flux_type does not equal flux_type_test - !! @throw FATAL, "Undefined flux_type/implementation (both given from field_table)" - !! flux_type does not equal flux_type_test - !! @throw FATAL, "Undefined flux_type/implementation given as argument to the subroutine" - !! flux_type does not equal flux_type_test - !! @throw NOTE, "Number of parameters provided for [variable] does not match the number of parameters required" - !! Mismatch between parameter input and the parameters being replaced - !! @throw FATAL, "Could not change back to [current_list]" - !! @throw FATAL, "Empty [name] list" - function AOF_SET_COUPLER_FLUX_(name, flux_type, implementation, atm_tr_index, param, flag,& - & mol_wt, ice_restart_file, ocean_restart_file, units, caller, verbosity) & - & result (coupler_index) - character(len=*), intent(in) :: name !< name - character(len=*), intent(in) :: flux_type !< flux_type - character(len=*), intent(in) :: implementation !< implementation - integer, intent(in), optional :: atm_tr_index !< atm_tr_index - real(FMS_CP_TYPE_), intent(in), dimension(:), optional :: param !< param - logical, intent(in), dimension(:), optional :: flag !< flag - real(FMS_CP_TYPE_), intent(in), optional :: mol_wt !< mol_wt - character(len=*), intent(in), optional :: ice_restart_file !< ice_restart_file - character(len=*), intent(in), optional :: ocean_restart_file !< ocean_restart_file - character(len=*), intent(in), optional :: units !< units - character(len=*), intent(in), optional :: caller !< caller - integer, intent(in), optional :: verbosity !< A 0-9 integer indicating a level of verbosity. - - integer :: coupler_index - - character(len=*), parameter :: sub_name = 'aof_set_coupler_flux' - - integer :: n - integer :: length - integer :: num_parameters - integer :: outunit - character(len=fm_path_name_len) :: coupler_list - character(len=fm_path_name_len) :: current_list - character(len=fm_string_len) :: flux_type_test - character(len=fm_string_len) :: implementation_test - character(len=256) :: error_header - character(len=256) :: warn_header - character(len=256) :: note_header - character(len=128) :: flux_list - character(len=128) :: caller_str - character(len=fm_string_len), pointer, dimension(:) :: good_list => NULL() - character(len=256) :: long_err_msg - integer :: verbose !< An integer indicating the level of verbosity. - - verbose = 5 ! Default verbosity level - if (present(verbosity)) verbose = verbosity - - ! Set the caller string and headers. - if (present(caller)) then - caller_str = '[' // trim(caller) // ']' - else - caller_str = fm_util_default_caller - endif - - error_header = '==>Error from ' // trim(mod_name) //& - & '(' // trim(sub_name) // ')' // trim(caller_str) // ':' - warn_header = '==>Warning from ' // trim(mod_name) //& - & '(' // trim(sub_name) // ')' // trim(caller_str) // ':' - note_header = '==>Note from ' // trim(mod_name) //& - & '(' // trim(sub_name) // ')' // trim(caller_str) // ':' - - ! Check that a name is given (fatal if not). - if (name .eq. ' ') then - call mpp_error(FATAL, trim(error_header) // ' Empty name given') - endif - outunit = stdout() - if (verbose >= 5) then - write (outunit,*) - write (outunit,*) trim(note_header), ' Processing coupler fluxes ', trim(name) - endif - - ! Define the coupler list name. - coupler_list = '/coupler_mod/fluxes/' // trim(name) - - ! Check whether a flux has already been set for this name, and if so, return the index for it - ! (this is because the fluxes may be defined in both the atmosphere and ocean models) (check - ! whether the good_list list exists, since this will indicate that this routine has already been - ! called, and not just that the field table input has this list defined) - if (fm_exists('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list')) then - if (verbose >= 5) then - write (outunit,*) - write (outunit,*) trim(note_header), ' Using previously defined coupler flux' - endif - coupler_index = fm_get_index(coupler_list) - if (coupler_index .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not get coupler flux ') - endif - - ! Allow atm_tr_index to be set here, since it will only be set from atmospheric - ! PEs, and the atmospheric routines call this routine last, thus overwriting the - ! current value is safe (furthermore, this is not a value which could have any meaningful - ! value set from the run script. - if (present(atm_tr_index)) then - if (verbose >= 5) & - write (outunit,*) trim(note_header), ' Redefining atm_tr_index to ', atm_tr_index - call fm_util_set_value(trim(coupler_list) // '/atm_tr_index', atm_tr_index,& - & no_create = .true., no_overwrite = .false., caller = caller_str) - endif - return - endif - - ! Set a new coupler flux and get its index. - coupler_index = fm_new_list(coupler_list) - if (coupler_index .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set coupler flux ') - endif - - ! Change to the new list, first saving the current list. - current_list = fm_get_current_list() - if (current_list .eq. ' ') then - call mpp_error(FATAL, trim(error_header) // ' Could not get the current list') - endif - - if (.not. fm_change_list(coupler_list)) then - call mpp_error(FATAL, trim(error_header) // ' Could not change to the new list') - endif - - ! Set the array in which to save the valid names for this list, - ! used later for a consistency check. This is used in the fm_util_set_value - ! routines to make the list of valid values. - call fm_util_set_good_name_list('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list') - - ! Set other defaults for the fm_util_set_value routines. - call fm_util_set_no_overwrite(.true.) - call fm_util_set_caller(caller_str) - - ! Set various values to given values, or to defaults if not given. - if (flux_type .eq. ' ') then - call mpp_error(FATAL, trim(error_header) // ' Blank flux_type given') - else - if (fm_exists('/coupler_mod/types/' // trim(flux_type))) then - call fm_util_set_value('flux_type', flux_type) - - ! Check that the flux_type that we will use (possibly given from the field_table) - ! is defined. - flux_type_test = fm_util_get_string('flux_type', scalar = .true.) - if (.not. fm_exists('/coupler_mod/types/' // trim(flux_type_test))) then - call mpp_error(FATAL, trim(error_header) //& - & ' Undefined flux_type given from field_table: ' // trim(flux_type_test)) - endif - else - call mpp_error(FATAL, trim(error_header) //& - & ' Undefined flux_type given as argument to the subroutine: ' // trim(flux_type)) - endif - endif - - if (implementation .eq. ' ') then - call mpp_error(FATAL, trim(error_header) // ' Blank flux_type given') - else - if (fm_exists('/coupler_mod/types/' // trim(flux_type) // '/implementation/' // trim(implementation))) then - call fm_util_set_value('implementation', implementation) - - ! Check that the flux_type/implementation that we will use - ! (both possibly given from the field_table) is defined - implementation_test = fm_util_get_string('implementation', scalar = .true.) - if (.not. fm_exists('/coupler_mod/types/' // trim(flux_type_test) // '/implementation/' // & - & trim(implementation_test))) then - if (flux_type .eq. flux_type_test) then - if (implementation .eq. implementation_test) then - call mpp_error(FATAL, trim(error_header) // ' Should not get here, as it is tested for above') - else - call mpp_error(FATAL, trim(error_header) //& - & ' Undefined flux_type/implementation (implementation given from field_table): ' //& - & trim(flux_type_test) // '/implementation/' // trim(implementation_test)) - endif - else - if (implementation .eq. implementation_test) then - long_err_msg = 'Undefined flux_type/implementation (flux_type given from field_table): ' - long_err_msg = long_err_msg // trim(flux_type_test) // '/implementation/'& - & // trim(implementation_test) - call mpp_error(FATAL, trim(error_header) // long_err_msg) - else - long_err_msg = ' Undefined flux_type/implementation (both given from field_table): ' - long_err_msg = long_err_msg // trim(flux_type_test) // '/implementation/'& - & // trim(implementation_test) - call mpp_error(FATAL, trim(error_header) // long_err_msg) - endif - endif - endif - else - call mpp_error(FATAL, trim(error_header) //& - & ' Undefined flux_type/implementation given as argument to the subroutine: ' //& - & trim(flux_type) // '/implementation/' // trim(implementation)) - endif - endif - - if (present(atm_tr_index)) then - call fm_util_set_value('atm_tr_index', atm_tr_index) - else - call fm_util_set_value('atm_tr_index', 0) - endif - - if (present(mol_wt)) then - call fm_util_set_value('mol_wt', mol_wt) - else - call fm_util_set_value('mol_wt', 0.0) - endif - - if (present(ice_restart_file)) then - call fm_util_set_value('ice_restart_file', ice_restart_file) - else - call fm_util_set_value('ice_restart_file', 'ice_coupler_fluxes.res.nc') - endif - - if (present(ocean_restart_file)) then - call fm_util_set_value('ocean_restart_file', ocean_restart_file) - else - call fm_util_set_value('ocean_restart_file', 'ocean_coupler_fluxes.res.nc') - endif - - if (present(param)) then - num_parameters = fm_util_get_integer('/coupler_mod/types/' //& - & trim(fm_util_get_string('flux_type', scalar = .true.)) // '/implementation/' //& - & trim(fm_util_get_string('implementation', scalar = .true.)) // '/num_parameters',& - & scalar = .true.) - length = min(size(param(:)),num_parameters) - if ((length .ne. num_parameters) .and. (verbose >= 5)) then - write (outunit,*) trim(note_header), ' Number of parameters provided for ', trim(name), ' does not match the' - write (outunit,*) 'number of parameters required (', size(param(:)), ' != ', num_parameters, ').' - write (outunit,*) 'This could be an error, or more likely is just a result of the implementation being' - write (outunit,*) 'overridden by the field table input' - endif - if (length .gt. 0) then - call fm_util_set_value('param', param(1:length), length) - else - call fm_util_set_value('param', 'null', index = 0) - endif - else - call fm_util_set_value('param', 'null', index = 0) - endif - - if (present(flag)) then - call fm_util_set_value('flag', flag, size(flag(:))) - else - call fm_util_set_value('flag', .false., index = 0) - endif - - flux_list = '/coupler_mod/types/' // trim(flux_type) // '/' - - if (present(units)) then - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = ind_flux)) // '-units',& - & units) - else - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = ind_flux)) // '-units',& - & fm_util_get_string(trim(flux_list) // 'flux/units', index = ind_flux)) - endif - - do n = 1, fm_util_get_length(trim(flux_list) // 'flux/name') - if (n .ne. ind_flux) then - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = n)) // '-units',& - & fm_util_get_string(trim(flux_list) // 'flux/units', index = n)) - endif - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = n)) // '-long_name',& - & fm_util_get_string(trim(flux_list) // 'flux/long_name', index = n)) - enddo ! n - - do n = 1, fm_util_get_length(trim(flux_list) // 'atm/name') - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = n)) //& - & '-units', fm_util_get_string(trim(flux_list) // 'atm/units', index = n)) - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = n)) // '-long_name',& - & fm_util_get_string(trim(flux_list) // 'atm/long_name', index = n)) - enddo ! n - - do n = 1, fm_util_get_length(trim(flux_list) // 'ice/name') - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = n)) // '-units',& - & fm_util_get_string(trim(flux_list) // 'ice/units', index = n)) - call fm_util_set_value(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = n)) // '-long_name',& - & fm_util_get_string(trim(flux_list) // 'ice/long_name', index = n)) - enddo ! n - - ! Reset the defaults for the fm_util_set_value calls. - call fm_util_reset_good_name_list - call fm_util_reset_no_overwrite - call fm_util_reset_caller - - ! Change back to the saved current list. - if (.not. fm_change_list(current_list)) then - call mpp_error(FATAL, trim(error_header) // ' Could not change back to ' // trim(current_list)) - endif - - ! Check for any errors in the number of fields in this list. - if (caller_str .eq. ' ') then - caller_str = trim(mod_name) // '(' // trim(sub_name) // ')' - endif - good_list => fm_util_get_string_array('/coupler_mod/GOOD/fluxes/' // trim(name) // '/good_list',& - & caller = caller_str) - if (associated(good_list)) then - call fm_util_check_for_bad_fields(trim(coupler_list), good_list, caller = caller_str) - deallocate(good_list) - else - call mpp_error(FATAL, trim(error_header) // ' Empty "' // trim(name) // '" list') - endif - - return - end function AOF_SET_COUPLER_FLUX_ - - !> @brief Initialize gas flux structures - !! @throw FATAL, "Could not get number of fluxes" - !! Number of gas fluxes is not a valid number - !! @throw NOTE, "No gas fluxes" - !! No gas fluxes were found - !! @throw NOTE, "Processing [gas_fluxes%num_bcs] gas fluxes" - !! Gas fluxes were found - !! @throw FATAL, "[name] is not a list" - !! name needs to be a list, or typ is incorrectly defined - !! @throw FATAL, "Flux index, [ind] does not match array index, [n] for [name]" - !! @throw FATAL, "Problem changing to [name]" - !! @throw FATAL, "Undefined flux_type given for [name]: [gas_fluxes%bc(n)%flux_type]" - !! @throw FATAL, "Undefined implementation given for [name]: - !! [gas_fluxes%bc(n)%flux_type]/implementation/[gas_fluxes%bc(n)%implementation]" - !! @throw FATAL, "No param for [name]: need [num_parameters]" - !! @throw FATAL, "Wrong number of param for [name]: [size(gas_fluxes%bc(n)%param(:))] given, need [num_parameters]" - !! @throw FATAL, "No params needed for [name] but has size of [size(gas_fluxes%bc(n)%param(:))]" - !! @throw FATAL, "Num_parameters is negative for [name]: [num_parameters]" - !! @throw FATAL, "No flag for [name]: need [num_flags]" - !! @throw FATAL, "Wrong number of flag for [name]: [size(gas_fluxes%bc(n)%flag(:))] given, need [num_flags]" - !! @throw FATAL, "No flags needed for [name] but has size of [size(gas_fluxes%bc(n)%flag(:))]" - !! @throw FATAL, "Num_flags is negative for [name]: [num_flags]" - !! @throw FATAL, "Problem dumping fluxes tracer tree" - !! @throw FATAL, "Number of fluxes does not match across the processors: [gas_fluxes%num_bcs] fluxes" - subroutine atmos_ocean_fluxes_init(gas_fluxes, gas_fields_atm, gas_fields_ice, verbosity) - - type(coupler_1d_bc_type), intent(inout) :: gas_fluxes !< Structure containing the gas fluxes between - !! the atmosphere and the ocean and parameters - !! related to the calculation of these fluxes. - !! The properties stored in this type are set - !! here, but the actual value arrays are set later. - type(coupler_1d_bc_type), intent(inout) :: gas_fields_atm !< Structure containing atmospheric surface - !! variables that are used in the calculation - !! of the atmosphere-ocean gas fluxes. - !! The properties stored in this type are set - !! here, but the actual value arrays are set later. - type(coupler_1d_bc_type), intent(inout) :: gas_fields_ice !< Structure containing ice-top and ocean - !! surface variables that are used in the - !! calculation of the atmosphere-ocean gas fluxes. - !! The properties stored in this type are set - !! here, but the actual value arrays are set later. - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - - character(len=*), parameter :: sub_name = 'atmos_ocean_fluxes_init' - character(len=*), parameter :: error_header =& - & '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):' - character(len=*), parameter :: warn_header =& - & '==>Warning from ' // trim(mod_name) // '(' // trim(sub_name) // '):' - character(len=*), parameter :: note_header =& - & '==>Note from ' // trim(mod_name) // '(' // trim(sub_name) // '):' - - integer :: num_parameters - integer :: num_flags - integer :: n - integer :: m - character(len=128) :: caller_str - character(len=fm_type_name_len) :: typ - character(len=fm_field_name_len) :: name - integer :: ind - integer :: outunit - integer :: total_fluxes - character(len=8) :: string - character(len=128) :: error_string - character(len=128) :: flux_list - logical, save :: initialized = .false. - integer :: verbose !< An integer indicating the level of verbosity. - - if (initialized) return - - verbose = 5 ! Default verbosity level - if (present(verbosity)) verbose = verbosity - - ! Write out the version of the file to the log file. - call write_version_number(trim(mod_name), version) - - initialized = .true. - outunit = stdout() - - ! initialize the coupler type flux tracers - call atmos_ocean_type_fluxes_init(verbose) - - if (verbose >= 9) then - write (outunit,*) - write (outunit,*) 'Dumping field manager tree' - if (.not. fm_dump_list('/', recursive = .true.)) & - call mpp_error(FATAL, trim(error_header) // ' Problem dumping field manager tree') - endif - - caller_str = trim(mod_name) // '(' // trim(sub_name) // ')' - - ! Set other defaults for the fm_util_set_value routines. - call fm_util_set_no_overwrite(.true.) - call fm_util_set_caller(caller_str) - - ! Determine the number of flux fields. - gas_fluxes%num_bcs = fm_util_get_length('/coupler_mod/fluxes/') - gas_fluxes%set = .true. - gas_fields_atm%num_bcs = gas_fluxes%num_bcs ; gas_fields_atm%set = .true. - gas_fields_ice%num_bcs = gas_fluxes%num_bcs ; gas_fields_ice%set = .true. - if (gas_fluxes%num_bcs .lt. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not get number of fluxes') - elseif (gas_fluxes%num_bcs .eq. 0) then - if (verbose >= 5) & - write (outunit,*) trim(note_header), ' No gas fluxes' - return - else - if (verbose >= 5) & - write (outunit,*) trim(note_header), ' Processing ', gas_fluxes%num_bcs, ' gas fluxes' - endif - - ! allocate the arrays - allocate (gas_fluxes%bc(gas_fluxes%num_bcs)) - allocate (gas_fields_atm%bc(gas_fields_atm%num_bcs)) - allocate (gas_fields_ice%bc(gas_fields_ice%num_bcs)) - - ! Loop over the input fields, setting the values in the flux_type. - n = 0 - do while (fm_loop_over_list('/coupler_mod/fluxes', name, typ, ind)) - if (typ .ne. 'list') then - call mpp_error(FATAL, trim(error_header) // ' ' // trim(name) // ' is not a list') - endif - - n = n + 1 ! increment the array index - - if (n .ne. ind) then - if (verbose >= 3) & - write (outunit,*) trim(warn_header), ' Flux index, ', ind,& - & ' does not match array index, ', n, ' for ', trim(name) - endif - - ! Change list to the new flux. - if (.not. fm_change_list('/coupler_mod/fluxes/' // trim(name))) then - call mpp_error(FATAL, trim(error_header) // ' Problem changing to ' // trim(name)) - endif - - ! Save and check the flux_type. - gas_fluxes%bc(n)%flux_type = fm_util_get_string('flux_type', scalar = .true.) - if (.not. fm_exists('/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type))) then - call mpp_error(FATAL, trim(error_header) // ' Undefined flux_type given for ' //& - & trim(name) // ': ' // trim(gas_fluxes%bc(n)%flux_type)) - endif - gas_fields_atm%bc(n)%flux_type = gas_fluxes%bc(n)%flux_type - gas_fields_ice%bc(n)%flux_type = gas_fluxes%bc(n)%flux_type - - ! Save and check the implementation. - gas_fluxes%bc(n)%implementation = fm_util_get_string('implementation', scalar = .true.) - if (.not. fm_exists('/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type) //& - & '/implementation/' // trim(gas_fluxes%bc(n)%implementation))) then - call mpp_error(FATAL, trim(error_header) // ' Undefined implementation given for ' //& - & trim(name) // ': ' // trim(gas_fluxes%bc(n)%flux_type) // '/implementation/' //& - & trim(gas_fluxes%bc(n)%implementation)) - endif - gas_fields_atm%bc(n)%implementation = gas_fluxes%bc(n)%implementation - gas_fields_ice%bc(n)%implementation = gas_fluxes%bc(n)%implementation - - ! Set the flux list name. - flux_list = '/coupler_mod/types/' // trim(gas_fluxes%bc(n)%flux_type) // '/' - - ! allocate the arrays - gas_fluxes%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'flux/name') - allocate (gas_fluxes%bc(n)%field(gas_fluxes%bc(n)%num_fields)) - gas_fields_atm%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'atm/name') - allocate (gas_fields_atm%bc(n)%field(gas_fields_atm%bc(n)%num_fields)) - gas_fields_ice%bc(n)%num_fields = fm_util_get_length(trim(flux_list) // 'ice/name') - allocate (gas_fields_ice%bc(n)%field(gas_fields_ice%bc(n)%num_fields)) - - ! Save the name and generate unique field names for Flux, Ice and Atm. - gas_fluxes%bc(n)%name = name - do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name') - gas_fluxes%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) //& - & 'flux/name', index = m) - gas_fluxes%bc(n)%field(m)%override = .false. - gas_fluxes%bc(n)%field(m)%mean = .false. - enddo - - gas_fields_atm%bc(n)%name = name - do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name') - gas_fields_atm%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) //& - & 'atm/name', index = m) - gas_fields_atm%bc(n)%field(m)%override = .false. - gas_fields_atm%bc(n)%field(m)%mean = .false. - enddo - - gas_fields_ice%bc(n)%name = name - do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name') - gas_fields_ice%bc(n)%field(m)%name = trim(name) // "_" // fm_util_get_string(trim(flux_list) // & - & 'ice/name', index = m) - gas_fields_ice%bc(n)%field(m)%override = .false. - gas_fields_ice%bc(n)%field(m)%mean = .false. - enddo - - ! Save the units. - do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name') - gas_fluxes%bc(n)%field(m)%units =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = m)) // & - & '-units', scalar = .true.) - enddo - do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name') - gas_fields_atm%bc(n)%field(m)%units =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = m)) // '-units') - enddo - do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name') - gas_fields_ice%bc(n)%field(m)%units =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = m)) // '-units') - enddo - - ! Save the long names. - do m = 1, fm_util_get_length(trim(flux_list) // 'flux/name') - gas_fluxes%bc(n)%field(m)%long_name =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'flux/name', index = m)) // & - & '-long_name', scalar = .true.) - gas_fluxes%bc(n)%field(m)%long_name = trim(gas_fluxes%bc(n)%field(m)%long_name) // ' for ' // name - enddo - do m = 1, fm_util_get_length(trim(flux_list) // 'atm/name') - gas_fields_atm%bc(n)%field(m)%long_name =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'atm/name', index = m)) // '-long_name') - gas_fields_atm%bc(n)%field(m)%long_name = trim(gas_fields_atm%bc(n)%field(m)%long_name) // ' for ' // name - enddo - do m = 1, fm_util_get_length(trim(flux_list) // 'ice/name') - gas_fields_ice%bc(n)%field(m)%long_name =& - & fm_util_get_string(trim(fm_util_get_string(trim(flux_list) // 'ice/name', index = m)) // '-long_name') - gas_fields_ice%bc(n)%field(m)%long_name = trim(gas_fields_ice%bc(n)%field(m)%long_name) // ' for ' // name - enddo - - ! Save the atm_tr_index. - gas_fluxes%bc(n)%atm_tr_index = fm_util_get_integer('atm_tr_index', scalar = .true.) - - ! Save the molecular weight. - gas_fluxes%bc(n)%mol_wt = fm_util_get_real('mol_wt', scalar = .true.) - gas_fields_atm%bc(n)%mol_wt = gas_fluxes%bc(n)%mol_wt - gas_fields_ice%bc(n)%mol_wt = gas_fluxes%bc(n)%mol_wt - - ! Save the ice_restart_file. - gas_fluxes%bc(n)%ice_restart_file = fm_util_get_string('ice_restart_file', scalar = .true.) - gas_fields_atm%bc(n)%ice_restart_file = gas_fluxes%bc(n)%ice_restart_file - gas_fields_ice%bc(n)%ice_restart_file = gas_fluxes%bc(n)%ice_restart_file - - ! Save the ocean_restart_file. - gas_fluxes%bc(n)%ocean_restart_file = fm_util_get_string('ocean_restart_file', scalar = .true.) - gas_fields_atm%bc(n)%ocean_restart_file = gas_fluxes%bc(n)%ocean_restart_file - gas_fields_ice%bc(n)%ocean_restart_file = gas_fluxes%bc(n)%ocean_restart_file - - ! Save the params. - gas_fluxes%bc(n)%param => fm_util_get_real_array('param') - - ! Save the flags. - gas_fluxes%bc(n)%flag => fm_util_get_logical_array('flag') - - ! Perform some integrity checks. - num_parameters = fm_util_get_integer(trim(flux_list) // 'implementation/' //& - & trim(gas_fluxes%bc(n)%implementation) // '/num_parameters', scalar = .true.) - if (num_parameters .gt. 0) then - if (.not. associated(gas_fluxes%bc(n)%param)) then - write (error_string,'(a,i2)') ': need ', num_parameters - call mpp_error(FATAL, trim(error_header) // ' No param for ' // trim(name) // trim(error_string)) - elseif (size(gas_fluxes%bc(n)%param(:)) .ne. num_parameters) then - write (error_string,'(a,i2,a,i2)') ': ', size(gas_fluxes%bc(n)%param(:)), ' given, need ', num_parameters - call mpp_error(FATAL, trim(error_header) // & - & ' Wrong number of param for ' // trim(name) // trim(error_string)) - endif - elseif (num_parameters .eq. 0) then - if (associated(gas_fluxes%bc(n)%param)) then - write (error_string,'(a,i3)') ' but has size of ', size(gas_fluxes%bc(n)%param(:)) - call mpp_error(FATAL, trim(error_header) // ' No params needed for ' // trim(name) // trim(error_string)) - endif - else - write (error_string,'(a,i2)') ': ', num_parameters - call mpp_error(FATAL, trim(error_header) // & - & 'Num_parameters is negative for ' // trim(name) // trim(error_string)) - endif - num_flags = fm_util_get_integer(trim(flux_list) // '/num_flags', scalar = .true.) - if (num_flags .gt. 0) then - if (.not. associated(gas_fluxes%bc(n)%flag)) then - write (error_string,'(a,i2)') ': need ', num_flags - call mpp_error(FATAL, trim(error_header) // ' No flag for ' // trim(name) // trim(error_string)) - elseif (size(gas_fluxes%bc(n)%flag(:)) .ne. num_flags) then - write (error_string,'(a,i2,a,i2)') ': ', size(gas_fluxes%bc(n)%flag(:)), ' given, need ', num_flags - call mpp_error(FATAL, trim(error_header) // ' Wrong number of flag for ' // trim(name) // trim(error_string)) - endif - elseif (num_flags .eq. 0) then - if (associated(gas_fluxes%bc(n)%flag)) then - write (error_string,'(a,i3)') ' but has size of ', size(gas_fluxes%bc(n)%flag(:)) - call mpp_error(FATAL, trim(error_header) // ' No flags needed for ' // trim(name) // trim(error_string)) - endif - else - write (error_string,'(a,i2)') ': ', num_flags - call mpp_error(FATAL, trim(error_header) // 'Num_flags is negative for ' // trim(name) // trim(error_string)) - endif - - ! Set some flags for this flux_type. - gas_fluxes%bc(n)%use_atm_pressure = fm_util_get_logical(trim(flux_list) // '/use_atm_pressure') - gas_fields_atm%bc(n)%use_atm_pressure = gas_fluxes%bc(n)%use_atm_pressure - gas_fields_ice%bc(n)%use_atm_pressure = gas_fluxes%bc(n)%use_atm_pressure - - gas_fluxes%bc(n)%use_10m_wind_speed = fm_util_get_logical(trim(flux_list) // '/use_10m_wind_speed') - gas_fields_atm%bc(n)%use_10m_wind_speed = gas_fluxes%bc(n)%use_10m_wind_speed - gas_fields_ice%bc(n)%use_10m_wind_speed = gas_fluxes%bc(n)%use_10m_wind_speed - - gas_fluxes%bc(n)%pass_through_ice = fm_util_get_logical(trim(flux_list) // '/pass_through_ice') - gas_fields_atm%bc(n)%pass_through_ice = gas_fluxes%bc(n)%pass_through_ice - gas_fields_ice%bc(n)%pass_through_ice = gas_fluxes%bc(n)%pass_through_ice - enddo ! while loop - - if (verbose >= 5) then - write (outunit,*) - write (outunit,*) 'Dumping fluxes tracer tree' - if (.not. fm_dump_list('/coupler_mod/fluxes', recursive = .true.)) then - call mpp_error(FATAL, trim(error_header) // ' Problem dumping fluxes tracer tree') - endif - endif - - ! Check that the number of fluxes is the same on all processors - ! If they are, then the sum of the number of fluxes across all processors - ! should equal to the number of fluxes on each processor times the number of processors - total_fluxes = gas_fluxes%num_bcs - call mpp_sum(total_fluxes) - if (total_fluxes .ne. mpp_npes() * gas_fluxes%num_bcs) then - write (string, '(i4)') gas_fluxes%num_bcs - call mpp_error(FATAL, trim(error_header) //& - & ' Number of fluxes does not match across the processors: ' // trim(string) // ' fluxes') - endif - - ! Reset the defaults for the fm_util_set_value calls. - call fm_util_reset_no_overwrite - call fm_util_reset_caller - end subroutine atmos_ocean_fluxes_init - - !> @brief Initialize the coupler type flux tracers - !> Initialize the /coupler_mod/types/ fields in the field manager. These fields - !! include: - !! @verbatim - !! air_sea_gas_flux_generic/ - !! implementation/ - !! ocmip2/ - !! num_parameters = 2 - !! num_flags = 0 - !! use_atm_pressure = t - !! use_10m_wind_speed = t - !! pass_through_ice = f - !! atm/ - !! name/ - !! pcair, u10, psurf - !! long_name/ - !! 'Atmospheric concentration' - !! 'Wind speed at 10 m' - !! 'Surface atmospheric pressure' - !! units/ - !! 'mol/mol', 'm/s', 'Pa' - !! ice/ - !! name/ - !! alpha, csurf, sc_no - !! long_name/ - !! 'Solubility from atmosphere' - !! 'Surface concentration from ocean' - !! 'Schmidt number' - !! units/ - !! 'mol/m^3/atm', 'mol/m^3', 'dimensionless' - !! flux/ - !! name/ - !! flux, deltap, kw - !! long_name/ - !! 'Surface gas flux' - !! 'ocean-air delta pressure' - !! 'piston velocity' - !! units/ - !! 'mol/m^2/s', 'uatm', 'm/s' - !! air_sea_gas_flux/ - !! implementation/ - !! ocmip2/ - !! num_parameters = 2 - !! ocmip2_data/ - !! num_parameters = 2 - !! linear/ - !! num_parameters = 3 - !! num_flags = 0 - !! use_atm_pressure = t - !! use_10m_wind_speed = t - !! pass_through_ice = f - !! atm/ - !! name/ - !! pcair, u10, psurf - !! long_name/ - !! 'Atmospheric concentration' - !! 'Wind speed at 10 m' - !! 'Surface atmospheric pressure' - !! units/ - !! 'mol/mol', 'm/s', 'Pa' - !! ice/ - !! name/ - !! alpha, csurf - !! long_name/ - !! 'Solubility from atmosphere' - !! 'Surface concentration from ocean' - !! units/ - !! 'mol/m^3/atm', 'mol/m^3' - !! flux/ - !! name/ - !! flux - !! long_name/ - !! 'Surface gas flux' - !! units/ - !! 'mol/m^2/s' - !! air_sea_deposition/ - !! implementation/ - !! dry/ - !! num_parameters = 1 - !! wet/ - !! num_parameters = 1 - !! num_flags = 0 - !! use_atm_pressure = f - !! use_10m_wind_speed = f - !! pass_through_ice = t - !! atm/ - !! name/ - !! depostion - !! long_name/ - !! 'Atmospheric deposition' - !! units/ - !! 'kg/m^2/s' - !! ice/ - !! name/ - !! long_name/ - !! units/ - !! flux/ - !! name/ - !! flux - !! long_name/ - !! 'Surface deposition' - !! units/ - !! 'mol/m^2/s' - !! land_sea_runoff/ - !! implementation/ - !! river/ - !! num_parameters = 1 - !! num_flags = 0 - !! use_atm_pressure = f - !! use_10m_wind_speed = f - !! pass_through_ice = t - !! atm/ ! really land (perhaps should change this?) - !! name/ - !! runoff - !! long_name/ - !! 'Concentration in land runoff' - !! units/ - !! 'kg/m^3' - !! ice/ - !! name/ - !! long_name/ - !! units/ - !! flux/ - !! name/ - !! flux - !! long_name/ - !! 'Concentration in land runoff' - !! units/ - !! 'mol/m^3' - !! @endverbatim - !! - !! @throw FATAL, Could not set the \coupler_mod\ list - !! @throw FATAL, Could not set the \GOOD\ list - !! @throw FATAL, Could not set the \/coupler_mod/fluxes\ list - !! @throw FATAL, Could not set the \/coupler_mod/types\ list - !! @throw FATAL, Could not change to \/coupler_mod/types\ - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic/implementation\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic/implementation/ocmip2\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic/atm\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic/ice\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux_generic/flux\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/implementation\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/implementation/ocmip2\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/implementation/ocmip2_data\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/implementation/linear\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/atm\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/ice\ list - !! @throw FATAL, Could not set the \air_sea_gas_flux/flux\ list - !! @throw FATAL, Could not set the \air_sea_deposition\ list - !! @throw FATAL, Could not set the \air_sea_deposition/implementation\ list - !! @throw FATAL, Could not set the \air_sea_deposition/implementation/dry\ list - !! @throw FATAL, Could not set the \air_sea_deposition/implementation/wet\ list - !! @throw FATAL, Could not set the \air_sea_deposition/atm\ list - !! @throw FATAL, Could not set the \air_sea_deposition/ice\ list - !! @throw FATAL, Could not set the \air_sea_deposition/flux\ list - !! @throw FATAL, Could not set the \land_sea_runoff\ list - !! @throw FATAL, Could not set the \land_sea_runoff/implementation\ list - !! @throw FATAL, Could not set the \land_sea_runoff/implementation/river\ list - !! @throw FATAL, Could not set the \land_sea_runoff/atm\ list - !! @throw FATAL, Could not set the \land_sea_runoff/ice\ list - !! @throw FATAL, Could not set the \land_sea_runoff/flux\ list - !! @throw FATAL, Could not change to \/\ - !! @throw FATAL, Problem dumping /coupler_mod/types tree - subroutine atmos_ocean_type_fluxes_init(verbosity) - integer, intent(in), optional :: verbosity !< A 0-9 integer indicating a level of verbosity. - - integer :: verbose !< An integer indicating the level of verbosity. - integer :: outunit - character(len=*), parameter :: sub_name = 'atmos_ocean_type_fluxes_init' - character(len=*), parameter :: caller_str =& - & trim(mod_name) // '(' // trim(sub_name) // ')' - character(len=*), parameter :: error_header =& - & '==>Error from ' // trim(mod_name) // '(' // trim(sub_name) // '):' - logical, save :: initialized = .false. - - if (initialized) return - - verbose = 5 ! Default verbosity level - if (present(verbosity)) verbose = verbosity - - initialized = .true. - - call fm_util_set_no_overwrite(.true.) - call fm_util_set_caller(caller_str) - - ! Be sure that the various lists and fields are defined in the field manager tree. - if (fm_new_list('/coupler_mod') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "coupler_mod" list') - endif - - if (fm_new_list('/coupler_mod/GOOD') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "GOOD" list') - endif - call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'GOOD', append = .true.) - - if (fm_new_list('/coupler_mod/fluxes') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "/coupler_mod/fluxes" list') - endif - call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'fluxes', append = .true.) - - if (fm_new_list('/coupler_mod/types') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "/coupler_mod/types" list') - endif - call fm_util_set_value('/coupler_mod/GOOD/good_coupler_mod_list', 'types', append = .true.) - - ! Change to the "/coupler_mod/types" list. - if (.not. fm_change_list('/coupler_mod/types')) then - call mpp_error(FATAL, trim(error_header) // ' Could not change to "/coupler_mod/types"') - endif - - - ! Define the air_sea_gas_flux_generic type and add it. - if (fm_new_list('air_sea_gas_flux_generic') .le. 0) then - call mpp_error(FATAL, trim(error_header) //& - & ' Could not set the "air_sea_gas_flux_generic" list') - endif - - ! Add the implementation list. - if (fm_new_list('air_sea_gas_flux_generic/implementation') .le. 0) then - call mpp_error(FATAL, trim(error_header) //& - & ' Could not set the "air_sea_gas_flux_generic/implementation" list') - endif - - ! Add the names of the different implementations. - if (fm_new_list('air_sea_gas_flux_generic/implementation/ocmip2') .le. 0) then - call mpp_error(FATAL, trim(error_header) //& - & ' Could not set the "air_sea_gas_flux_generic/implementation/ocmip2" list') - endif - call fm_util_set_value('air_sea_gas_flux_generic/implementation/ocmip2/num_parameters', 2) - - if (fm_new_list('air_sea_gas_flux_generic/implementation/duce') .le. 0) then - call mpp_error(FATAL, trim(error_header) //& - & ' Could not set the "air_sea_gas_flux_generic/implementation/duce" list') - endif - call fm_util_set_value('air_sea_gas_flux_generic/implementation/duce/num_parameters', 1) - - if (fm_new_list('air_sea_gas_flux_generic/implementation/johnson') .le. 0) then - call mpp_error(FATAL, trim(error_header) // & - & ' Could not set the "air_sea_gas_flux_generic/implementation/johnson" list') - endif - call fm_util_set_value('air_sea_gas_flux_generic/implementation/johnson/num_parameters', 2) - - ! Add some scalar quantaties. - call fm_util_set_value('air_sea_gas_flux_generic/num_flags', 0) - call fm_util_set_value('air_sea_gas_flux_generic/use_atm_pressure', .true.) - call fm_util_set_value('air_sea_gas_flux_generic/use_10m_wind_speed', .true.) - call fm_util_set_value('air_sea_gas_flux_generic/pass_through_ice', .false.) - - ! Add required fields that will come from the atmosphere model. - if (fm_new_list('air_sea_gas_flux_generic/atm') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/atm" list') - endif - - call fm_util_set_value('air_sea_gas_flux_generic/atm/name', 'pcair', index = ind_pcair) - call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Atmospheric concentration', index = ind_pcair) - call fm_util_set_value('air_sea_gas_flux_generic/atm/units', 'mol/mol', index = ind_pcair) - - call fm_util_set_value('air_sea_gas_flux_generic/atm/name', 'u10', index = ind_u10) - call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Wind speed at 10 m', index = ind_u10) - call fm_util_set_value('air_sea_gas_flux_generic/atm/units', 'm/s', index = ind_u10) - - call fm_util_set_value('air_sea_gas_flux_generic/atm/name', 'psurf', index = ind_psurf) - call fm_util_set_value('air_sea_gas_flux_generic/atm/long_name', 'Surface atmospheric pressure', index = ind_psurf) - call fm_util_set_value('air_sea_gas_flux_generic/atm/units', 'Pa', index = ind_psurf) - - ! Add required fields that will come from the ice model. - if (fm_new_list('air_sea_gas_flux_generic/ice') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/ice" list') - endif - - call fm_util_set_value('air_sea_gas_flux_generic/ice/name', 'alpha', index = ind_alpha) - call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Solubility w.r.t. atmosphere', index = ind_alpha) - call fm_util_set_value('air_sea_gas_flux_generic/ice/units', 'mol/m^3/atm', index = ind_alpha) - - call fm_util_set_value('air_sea_gas_flux_generic/ice/name', 'csurf', index = ind_csurf) - call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Ocean concentration', index = ind_csurf) - call fm_util_set_value('air_sea_gas_flux_generic/ice/units', 'mol/m^3', index = ind_csurf) - - call fm_util_set_value('air_sea_gas_flux_generic/ice/name', 'sc_no', index = ind_sc_no) - call fm_util_set_value('air_sea_gas_flux_generic/ice/long_name', 'Schmidt number', index = ind_sc_no) - call fm_util_set_value('air_sea_gas_flux_generic/ice/units', 'dimensionless', index = ind_sc_no) - - ! Add the flux output field(s). - if (fm_new_list('air_sea_gas_flux_generic/flux') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux_generic/flux" list') - endif - - call fm_util_set_value('air_sea_gas_flux_generic/flux/name', 'flux', index = ind_flux) - call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Surface flux', index = ind_flux) - call fm_util_set_value('air_sea_gas_flux_generic/flux/units', 'mol/m^2/s', index = ind_flux) - - call fm_util_set_value('air_sea_gas_flux_generic/flux/name', 'deltap', index = ind_deltap) - call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Ocean-air delta pressure', index = ind_deltap) - call fm_util_set_value('air_sea_gas_flux_generic/flux/units', 'uatm', index = ind_deltap) - - call fm_util_set_value('air_sea_gas_flux_generic/flux/name', 'kw', index = ind_kw) - call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Piston velocity', index = ind_kw) - call fm_util_set_value('air_sea_gas_flux_generic/flux/units', 'm/s', index = ind_kw) - - call fm_util_set_value('air_sea_gas_flux_generic/flux/name', 'flux0', index = ind_flux0) - call fm_util_set_value('air_sea_gas_flux_generic/flux/long_name', 'Surface flux no atm', index = ind_flux0) - call fm_util_set_value('air_sea_gas_flux_generic/flux/units', 'mol/m^2/s', index = ind_flux0) - - ! Define the air_sea_gas_flux type and add it. - if (fm_new_list('air_sea_gas_flux') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux" list') - endif - - ! Add the implementation list. - if (fm_new_list('air_sea_gas_flux/implementation') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation" list') - endif - - ! Add the names of the different implementations. - if (fm_new_list('air_sea_gas_flux/implementation/ocmip2') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation/ocmip2" list') - endif - call fm_util_set_value('air_sea_gas_flux/implementation/ocmip2/num_parameters', 2) - if (fm_new_list('air_sea_gas_flux/implementation/ocmip2_data') .le. 0) then - call mpp_error(FATAL, trim(error_header) // & - & ' Could not set the "air_sea_gas_flux/implementation/ocmip2_data" list') - endif - call fm_util_set_value('air_sea_gas_flux/implementation/ocmip2_data/num_parameters', 2) - if (fm_new_list('air_sea_gas_flux/implementation/linear') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/implementation/linear" list') - endif - call fm_util_set_value('air_sea_gas_flux/implementation/linear/num_parameters', 3) - - ! Add some scalar quantaties. - call fm_util_set_value('air_sea_gas_flux/num_flags', 0) - call fm_util_set_value('air_sea_gas_flux/use_atm_pressure', .true.) - call fm_util_set_value('air_sea_gas_flux/use_10m_wind_speed', .true.) - call fm_util_set_value('air_sea_gas_flux/pass_through_ice', .false.) - - ! Add required fields that will come from the atmosphere model. - if (fm_new_list('air_sea_gas_flux/atm') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/atm" list') - endif - - call fm_util_set_value('air_sea_gas_flux/atm/name', 'pcair', index = ind_pcair) - call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Atmospheric concentration', index = ind_pcair) - call fm_util_set_value('air_sea_gas_flux/atm/units', 'mol/mol', index = ind_pcair) - - call fm_util_set_value('air_sea_gas_flux/atm/name', 'u10', index = ind_u10) - call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Wind speed at 10 m', index = ind_u10) - call fm_util_set_value('air_sea_gas_flux/atm/units', 'm/s', index = ind_u10) - - call fm_util_set_value('air_sea_gas_flux/atm/name', 'psurf', index = ind_psurf) - call fm_util_set_value('air_sea_gas_flux/atm/long_name', 'Surface atmospheric pressure', index = ind_psurf) - call fm_util_set_value('air_sea_gas_flux/atm/units', 'Pa', index = ind_psurf) - - ! Add required fields that will come from the ice model. - if (fm_new_list('air_sea_gas_flux/ice') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/ice" list') - endif - - call fm_util_set_value('air_sea_gas_flux/ice/name', 'alpha', index = ind_alpha) - call fm_util_set_value('air_sea_gas_flux/ice/long_name', & - & 'Solubility from atmosphere times Schmidt number term', index = ind_alpha) - call fm_util_set_value('air_sea_gas_flux/ice/units', 'mol/m^3/atm', index = ind_alpha) - - call fm_util_set_value('air_sea_gas_flux/ice/name', 'csurf', index = ind_csurf) - call fm_util_set_value('air_sea_gas_flux/ice/long_name', 'Ocean concentration times Schmidt number term', & - & index = ind_csurf) - call fm_util_set_value('air_sea_gas_flux/ice/units', 'mol/m^3', index = ind_csurf) - - ! Add the flux output field(s). - if (fm_new_list('air_sea_gas_flux/flux') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_gas_flux/flux" list') - endif - - call fm_util_set_value('air_sea_gas_flux/flux/name', 'flux', index = ind_flux) - call fm_util_set_value('air_sea_gas_flux/flux/long_name', 'Surface flux', index = ind_flux) - call fm_util_set_value('air_sea_gas_flux/flux/units', 'mol/m^2/s', index = ind_flux) - - ! Define the air_sea_deposition type and add it. - if (fm_new_list('air_sea_deposition') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition" list') - endif - - ! Add the implementation list. - if (fm_new_list('air_sea_deposition/implementation') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation" list') - endif - - ! Add the names of the different implementations. - if (fm_new_list('air_sea_deposition/implementation/dry') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation/dry" list') - endif - call fm_util_set_value('air_sea_deposition/implementation/dry/num_parameters', 1) - if (fm_new_list('air_sea_deposition/implementation/wet') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/implementation/wet" list') - endif - call fm_util_set_value('air_sea_deposition/implementation/wet/num_parameters', 1) - - ! Add some scalar quantaties. - call fm_util_set_value('air_sea_deposition/num_flags', 0) - call fm_util_set_value('air_sea_deposition/use_atm_pressure', .false.) - call fm_util_set_value('air_sea_deposition/use_10m_wind_speed', .false.) - call fm_util_set_value('air_sea_deposition/pass_through_ice', .true.) - - ! Add required fields that will come from the atmosphere model. - if (fm_new_list('air_sea_deposition/atm') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/atm" list') - endif - - call fm_util_set_value('air_sea_deposition/atm/name', 'deposition', index = ind_deposition) - call fm_util_set_value('air_sea_deposition/atm/long_name', 'Atmospheric deposition', index = ind_deposition) - call fm_util_set_value('air_sea_deposition/atm/units', 'kg/m^2/s', index = ind_deposition) - - ! Add required fields that will come from the ice model. - if (fm_new_list('air_sea_deposition/ice') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/ice" list') - endif - - call fm_util_set_value('air_sea_deposition/ice/name', ' ', index = 0) - call fm_util_set_value('air_sea_deposition/ice/long_name', ' ', index = 0) - call fm_util_set_value('air_sea_deposition/ice/units', ' ', index = 0) - - ! Add the flux output field(s). - if (fm_new_list('air_sea_deposition/flux') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "air_sea_deposition/flux" list') - endif - - call fm_util_set_value('air_sea_deposition/flux/name', 'flux', index = ind_flux) - call fm_util_set_value('air_sea_deposition/flux/long_name', 'Surface deposition', index = ind_flux) - call fm_util_set_value('air_sea_deposition/flux/units', 'mol/m^2/s', index = ind_flux) - - ! Define the land_sea_runoff type and add it. - if (fm_new_list('land_sea_runoff') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff" list') - endif - - ! Add the implementation list. - if (fm_new_list('land_sea_runoff/implementation') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/implementation" list') - endif - - ! Add the names of the different implementations. - if (fm_new_list('land_sea_runoff/implementation/river') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/implementation/river" list') - endif - call fm_util_set_value('land_sea_runoff/implementation/river/num_parameters', 1) - - ! Add some scalar quantaties. - call fm_util_set_value('land_sea_runoff/num_flags', 0) - call fm_util_set_value('land_sea_runoff/use_atm_pressure', .false.) - call fm_util_set_value('land_sea_runoff/use_10m_wind_speed', .false.) - call fm_util_set_value('land_sea_runoff/pass_through_ice', .true.) - - ! Add required fields that will come from the land model (the array name is still called "atm"). - if (fm_new_list('land_sea_runoff/atm') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/atm" list') - endif - - call fm_util_set_value('land_sea_runoff/atm/name', 'runoff', index = ind_runoff) - call fm_util_set_value('land_sea_runoff/atm/long_name', 'Concentration in land runoff', index = ind_runoff) - call fm_util_set_value('land_sea_runoff/atm/units', 'mol/m^3', index = ind_runoff) - - ! Add required fields that will come from the ice model. - if (fm_new_list('land_sea_runoff/ice') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/ice" list') - endif - - call fm_util_set_value('land_sea_runoff/ice/name', ' ', index = 0) - call fm_util_set_value('land_sea_runoff/ice/long_name', ' ', index = 0) - call fm_util_set_value('land_sea_runoff/ice/units', ' ', index = 0) - - ! Add the flux output field(s). - - if (fm_new_list('land_sea_runoff/flux') .le. 0) then - call mpp_error(FATAL, trim(error_header) // ' Could not set the "land_sea_runoff/flux" list') - endif - - call fm_util_set_value('land_sea_runoff/flux/name', 'flux', index = ind_flux) - call fm_util_set_value('land_sea_runoff/flux/long_name', 'Concentration in land runoff', index = ind_flux) - call fm_util_set_value('land_sea_runoff/flux/units', 'mol/m^3', index = ind_flux) - - ! Change back to root list. - if (.not. fm_change_list('/')) then - call mpp_error(FATAL, trim(error_header) // ' Could not change to "/"') - endif - - ! Reset the defaults for the fm_util_set_value calls. - call fm_util_reset_no_overwrite - call fm_util_reset_caller - - ! Dump the coupler_mod types list. - if (verbose >= 5) then - outunit = stdout() - write (outunit,*) - write (outunit,*) 'Dumping coupler_mod/types tree' - if (.not. fm_dump_list('/coupler_mod/types', recursive = .true.)) then - call mpp_error(FATAL, trim(error_header) // ' Problem dumping /coupler_mod/types tree') - endif - endif - return - end subroutine atmos_ocean_type_fluxes_init -end module atmos_ocean_fluxes_mod -!> @} -! close documentation grouping diff --git a/coupler/include/coupler_types.inc b/coupler/include/coupler_types.inc index dcd65e8db5..bcf1795eb8 100644 --- a/coupler/include/coupler_types.inc +++ b/coupler/include/coupler_types.inc @@ -23,1657 +23,18 @@ !> @addtogroup coupler_types_mod !> @{ -module coupler_types_mod - use fms_mod, only: write_version_number, lowercase - use fms2_io_mod, only: FmsNetcdfDomainFile_t, open_file, register_restart_field - use fms2_io_mod, only: register_axis, unlimited, variable_exists, check_if_open - use fms2_io_mod, only: register_field, get_num_dimensions, variable_att_exists - use fms2_io_mod, only: get_variable_attribute, get_dimension_size, get_dimension_names - use fms2_io_mod, only: register_variable_attribute, get_variable_dimension_names - use fms2_io_mod, only: get_variable_num_dimensions -#ifdef use_deprecated_io - use fms_io_mod, only: restart_file_type, fms_io_register_restart_field=>register_restart_field - use fms_io_mod, only: query_initialized, restore_state -#endif - use time_manager_mod, only: time_type - use diag_manager_mod, only: register_diag_field, send_data - use data_override_mod, only: data_override - use mpp_domains_mod, only: domain2D, mpp_redistribute - use mpp_mod, only: mpp_error, FATAL, mpp_chksum - - use iso_fortran_env, only : int32, int64 !To get mpp_chksum value - - implicit none - private - - - ! Include variable "version" to be written to log file. -#include - - public coupler_types_init - public coupler_type_copy, coupler_type_spawn, coupler_type_set_diags - public coupler_type_write_chksums, coupler_type_send_data, coupler_type_data_override - public coupler_type_register_restarts, coupler_type_restore_state - public coupler_type_increment_data, coupler_type_rescale_data - public coupler_type_copy_data, coupler_type_redistribute_data - public coupler_type_destructor, coupler_type_initialized - public coupler_type_extract_data, coupler_type_set_data - - public coupler_type_copy_1d_2d - public coupler_type_copy_1d_3d - - character(len=*), parameter :: mod_name = 'coupler_types_mod' - -!> @} - - !> Coupler data for 3D values - !> @ingroup coupler_types_mod - type, public :: coupler_3d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file - end type coupler_3d_values_type - - !> Coupler data for 3D fields - !> @ingroup coupler_types_mod - type, public :: coupler_3d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_3d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file -#ifdef use_deprecated_io - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. -#endif - type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type - !! That is used for this field - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt - end type coupler_3d_field_type - - !> Coupler data for 3D boundary conditions - !> @ingroup coupler_types_mod - type, public :: coupler_3d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type - integer :: ks, ke !< The k-direction index ranges for this type - end type coupler_3d_bc_type - - - !> Coupler data for 2D values - !> @ingroup coupler_types_mod - type, public :: coupler_2d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, contiguous, dimension(:,:) :: values => NULL() !< The pointer to the - !! array of values for this field; this - !! should be changed to allocatable - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - integer :: id_rest = 0 !< The id of this array in the restart field - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file - end type coupler_2d_values_type - - !> Coupler data for 2D fields - !> @ingroup coupler_types_mod - type, public :: coupler_2d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_2d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file -#ifdef use_deprecated_io - type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type - !! that is used for this field. -#endif - type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type - !! That is used for this field - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt - end type coupler_2d_field_type - - !> Coupler data for 2D boundary conditions - !> @ingroup coupler_types_mod - type, public :: coupler_2d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type - integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type - end type coupler_2d_bc_type - - !> Coupler data for 1D values - !> @ingroup coupler_types_mod - type, public :: coupler_1d_values_type - character(len=48) :: name = ' ' !< The diagnostic name for this array - real, pointer, dimension(:) :: values => NULL() !< The pointer to the array of values - logical :: mean = .true. !< mean - logical :: override = .false. !< override - integer :: id_diag = 0 !< The diagnostic id for this array - character(len=128) :: long_name = ' ' !< The diagnostic long_name for this array - character(len=128) :: units = ' ' !< The units for this array - logical :: may_init = .true. !< If true, there is an internal method - !! that can be used to initialize this field - !! if it can not be read from a restart file - end type coupler_1d_values_type - - !> Coupler data for 1D fields - !> @ingroup coupler_types_mod - type, public :: coupler_1d_field_type - character(len=48) :: name = ' ' !< name - integer :: num_fields = 0 !< num_fields - type(coupler_1d_values_type), pointer, dimension(:) :: field => NULL() !< field - character(len=128) :: flux_type = ' ' !< flux_type - character(len=128) :: implementation = ' ' !< implementation - real, pointer, dimension(:) :: param => NULL() !< param - logical, pointer, dimension(:) :: flag => NULL() !< flag - integer :: atm_tr_index = 0 !< atm_tr_index - character(len=128) :: ice_restart_file = ' ' !< ice_restart_file - character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file - logical :: use_atm_pressure !< use_atm_pressure - logical :: use_10m_wind_speed !< use_10m_wind_speed - logical :: pass_through_ice !< pass_through_ice - real :: mol_wt = 0.0 !< mol_wt - end type coupler_1d_field_type - - !> Coupler data for 1D boundary conditions - !> @ingroup coupler_types_mod - type, public :: coupler_1d_bc_type - integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary - !! condition fields - logical :: set = .false. !< If true, this type has been initialized - end type coupler_1d_bc_type - - !> @addtogroup coupler_types_mod - !> @{ - ! The following public parameters can help in selecting the sub-elements of a - ! coupler type. There are duplicate values because different boundary - ! conditions have different sub-elements. - ! Note: These should be parameters, but doing so would break openMP directives. - integer, public :: ind_pcair = 1 !< The index of the atmospheric concentration - integer, public :: ind_u10 = 2 !< The index of the 10 m wind speed - integer, public :: ind_psurf = 3 !< The index of the surface atmospheric pressure - integer, public :: ind_alpha = 1 !< The index of the solubility array for a tracer - integer, public :: ind_csurf = 2 !< The index of the ocean surface concentration - integer, public :: ind_sc_no = 3 !< The index for the Schmidt number for a tracer flux - integer, public :: ind_flux = 1 !< The index for the tracer flux - integer, public :: ind_deltap= 2 !< The index for ocean-air gas partial pressure change - integer, public :: ind_kw = 3 !< The index for the piston velocity - integer, public :: ind_flux0 = 4 !< The index for the piston velocity - integer, public :: ind_deposition = 1 !< The index for the atmospheric deposition flux - integer, public :: ind_runoff = 1 !< The index for a runoff flux - !> @} - - ! Interface definitions for overloaded routines - - !> This is the interface to spawn one coupler_bc_type into another and then - !! register diagnostics associated with the new type. - !> @ingroup coupler_types_mod - interface coupler_type_copy - module procedure coupler_type_copy_1d_2d, coupler_type_copy_1d_3d - module procedure coupler_type_copy_2d_2d, coupler_type_copy_2d_3d - module procedure coupler_type_copy_3d_2d, coupler_type_copy_3d_3d - end interface coupler_type_copy - - !> This is the interface to spawn one coupler_bc_type into another. - !> @ingroup coupler_types_mod - interface coupler_type_spawn - module procedure CT_spawn_1d_2d, CT_spawn_2d_2d, CT_spawn_3d_2d - module procedure CT_spawn_1d_3d, CT_spawn_2d_3d, CT_spawn_3d_3d - end interface coupler_type_spawn - - !> This is the interface to copy the field data from one coupler_bc_type - !! to another of the same rank, size and decomposition. - !> @ingroup coupler_types_mod - interface coupler_type_copy_data - module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d - end interface coupler_type_copy_data - - !> This is the interface to redistribute the field data from one coupler_bc_type - !! to another of the same rank and global size, but a different decomposition. - !> @ingroup coupler_types_mod - interface coupler_type_redistribute_data - module procedure CT_redistribute_data_2d, CT_redistribute_data_3d - end interface coupler_type_redistribute_data - - !> This is the interface to rescale the field data in a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_rescale_data - module procedure CT_rescale_data_2d, CT_rescale_data_3d - end interface coupler_type_rescale_data - - !> This is the interface to increment the field data from one coupler_bc_type - !! with the data from another. Both must have the same horizontal size and - !! decomposition, but a 2d type may be incremented by a 2d or 3d type - !> @ingroup coupler_types_mod - interface coupler_type_increment_data - module procedure CT_increment_data_2d_2d, CT_increment_data_3d_3d, CT_increment_data_2d_3d - end interface coupler_type_increment_data - - !> This is the interface to extract a field in a coupler_bc_type into an array. - !> @ingroup coupler_types_mod - interface coupler_type_extract_data - module procedure CT_extract_data_2d, CT_extract_data_3d, CT_extract_data_3d_2d - end interface coupler_type_extract_data - - !> This is the interface to set a field in a coupler_bc_type from an array. - !> @ingroup coupler_types_mod - interface coupler_type_set_data - module procedure CT_set_data_2d, CT_set_data_3d, CT_set_data_2d_3d - end interface coupler_type_set_data - - !> This is the interface to set diagnostics for the arrays in a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_set_diags - module procedure CT_set_diags_2d, CT_set_diags_3d - end interface coupler_type_set_diags - - !> This is the interface to write out checksums for the elements of a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_write_chksums - module procedure CT_write_chksums_2d, CT_write_chksums_3d - end interface coupler_type_write_chksums - - !> This is the interface to write out diagnostics of the arrays in a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_send_data - module procedure CT_send_data_2d, CT_send_data_3d - end interface coupler_type_send_data - - !> This is the interface to override the values of the arrays in a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_data_override - module procedure CT_data_override_2d, CT_data_override_3d - end interface coupler_type_data_override - - !> This is the interface to register the fields in a coupler_bc_type to be saved - !! in restart files. - !> @ingroup coupler_types_mod - interface coupler_type_register_restarts -#ifdef use_deprecated_io - module procedure mpp_io_CT_register_restarts_2d, mpp_io_CT_register_restarts_3d - module procedure mpp_io_CT_register_restarts_to_file_2d, mpp_io_CT_register_restarts_to_file_3d -#endif - module procedure CT_register_restarts_2d, CT_register_restarts_3d - end interface coupler_type_register_restarts - - !> This is the interface to read in the fields in a coupler_bc_type that have - !! been saved in restart files. - !> @ingroup coupler_types_mod - interface coupler_type_restore_state -#ifdef use_deprecated_io - module procedure mpp_io_CT_restore_state_2d, mpp_io_CT_restore_state_3d -#endif - module procedure CT_restore_state_2d, CT_restore_state_3d - end interface coupler_type_restore_state - - !> This function interface indicates whether a coupler_bc_type has been initialized. - !> @ingroup coupler_types_mod - interface coupler_type_initialized - module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d - end interface coupler_type_initialized - - !> This is the interface to deallocate any data associated with a coupler_bc_type. - !> @ingroup coupler_types_mod - interface coupler_type_destructor - module procedure CT_destructor_1d, CT_destructor_2d, CT_destructor_3d - end interface coupler_type_destructor - -contains !> @addtogroup coupler_types_mod !> @{ - !> @brief Initialize the coupler types - subroutine coupler_types_init - - logical, save :: module_is_initialized = .false. - - ! Return if already intialized - if (module_is_initialized) then - return - endif - - ! Write out the version of the file to the log file. - call write_version_number(trim(mod_name), version) - - module_is_initialized = .true. - - return - end subroutine coupler_types_init !} - - - !> @brief Copy fields from one coupler type to another. 1-D to 2-D version for generic coupler_type_copy. - !! - !! @throw FATAL, "Number of output fields exceeds zero" - subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je,& - & diag_name, axes, time, suffix) - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_2d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_1d_2d - - !> @brief Copy fields from one coupler type to another. 1-D to 3-D version for generic coupler_type_copy. - !! - !! - !! @throw FATAL, "Number of output fields is exceeds zero" - subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd,& - & diag_name, axes, time, suffix) - type(coupler_1d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_3d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_1d_3d - - !> @brief Copy fields from one coupler type to another. 2-D to 2-D version for generic coupler_type_copy. - !! - !! @throw FATAL, "Number of output fields is exceeds zero" - subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je,& - & diag_name, axes, time, suffix) - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_2d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_2d_2d - - !> @brief Copy fields from one coupler type to another. 2-D to 3-D version for generic coupler_type_copy. - !! - !! @throw FATAL, "Number of output fields is exceeds zero" - subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd,& - & diag_name, axes, time, suffix) - type(coupler_2d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_3d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_2d_3d - - !> @brief Copy fields from one coupler type to another. 3-D to 2-D version for generic coupler_type_copy. - !! - !! @throw FATAL, "Number of output fields is exceeds zero" - subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je,& - & diag_name, axes, time, suffix) - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_2d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_2d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_3d_2d - - !> @brief Copy fields from one coupler type to another. 3-D to 3-D version for generic coupler_type_copy. - !! - !! @throw FATAL, "Number of output fields exceeds zero" - subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd,& - & diag_name, axes, time, suffix) - type(coupler_3d_bc_type), intent(in) :: var_in !< variable to copy information from - type(coupler_3d_bc_type), intent(inout) :: var_out !< variable to copy information to - integer, intent(in) :: is !< lower bound of first dimension - integer, intent(in) :: ie !< upper bound of first dimension - integer, intent(in) :: js !< lower bound of second dimension - integer, intent(in) :: je !< upper bound of second dimension - integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - - if (var_out%num_bcs > 0) then - ! It is an error if the number of output fields exceeds zero, because it means this - ! type has already been populated. - call mpp_error(FATAL, trim(error_header) // ' Number of output fields exceeds zero') - endif - - if (var_in%num_bcs >= 0)& - & call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' '))& - & call CT_set_diags_3d(var_out, diag_name, axes, time) - end subroutine coupler_type_copy_3d_3d - - - !> @brief Generate one coupler type using another as a template. 1-D to 2-D version for generic coupler_type_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_1d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)&Crontab Explanation - - As you can see, the crontab syntax has 5 asterisks. Here’s what each of those asterisk represent: - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header),& - & ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_1d_2d - - !> @brief Generate one coupler type using another as a template. 1-D to 3-D version for generic CT_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_1d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)& - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_1d_3d - - - !> @brief Generate one coupler type using another as a template. 2-D to 2-D version for generic CT_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_2d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)& - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_2d_2d - - !> @brief Generate one coupler type using another as a template. 2-D to 3-D version for generic CT_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "Disordered k-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_2d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)& - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - ! Store the array extents that are to be used with this bc_type. - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_2d_3d - - !> @brief Generate one coupler type using another as a template. 3-D to 2-D version for generic CT_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_3d_2d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)& - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) ) - var%bc(n)%field(m)%values(:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_3d_2d - - !> @brief Generate one coupler type using another as a template. 3-D to 3-D version for generic CT_spawn. - !! - !! @throw FATAL, "The output type has already been initialized" - !! @throw FATAL, "The parent type has not been initialized" - !! @throw FATAL, "Disordered i-dimension index bound list" - !! @throw FATAL, "Disordered j-dimension index bound list" - !! @throw FATAL, "Disordered k-dimension index bound list" - !! @throw FATAL, "var%bc already assocated" - !! @throw FATAL, "var%bc('n')%field already associated" - !! @throw FATAL, "var%bc('n')%field('m')%values already associated" - subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) - type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information - type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information - integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of - !! the first dimension in a non-decreasing list - integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of - !! the second dimension in a non-decreasing list - integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in - !! a non-decreasing list - character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique - logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) - !! is not set and the parent type (var_in) is set. - - character(len=*), parameter :: error_header =& - & '==>Error from coupler_types_mod (CT_spawn_3d_3d):' - character(len=400) :: error_msg - integer :: m, n - - if (present(as_needed)) then - if (as_needed) then - if ((var%set) .or. (.not.var_in%set)) return - endif - endif - - if (var%set)& - & call mpp_error(FATAL, trim(error_header) // ' The output type has already been initialized.') - if (.not.var_in%set)& - & call mpp_error(FATAL, trim(error_header) // ' The parent type has not been initialized.') - - var%num_bcs = var_in%num_bcs - var%set = .true. - - if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then - write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim - call mpp_error(FATAL, trim(error_msg)) - endif - if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then - write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim - call mpp_error(FATAL, trim(error_msg)) - endif - if (kdim(1) > kdim(2)) then - write (error_msg, *) trim(error_header), ' Disordered k-dimension index bound list ', kdim - call mpp_error(FATAL, trim(error_msg)) - endif - var%isd = idim(1) ; var%isc = idim(2) ; var%iec = idim(3) ; var%ied = idim(4) - var%jsd = jdim(1) ; var%jsc = jdim(2) ; var%jec = jdim(3) ; var%jed = jdim(4) - var%ks = kdim(1) ; var%ke = kdim(2) - - if (var%num_bcs > 0) then - if (associated(var%bc)) then - call mpp_error(FATAL, trim(error_header) // ' var%bc already associated') - endif - allocate ( var%bc(var%num_bcs) ) - do n = 1, var%num_bcs - var%bc(n)%name = var_in%bc(n)%name - var%bc(n)%atm_tr_index = var_in%bc(n)%atm_tr_index - var%bc(n)%flux_type = var_in%bc(n)%flux_type - var%bc(n)%implementation = var_in%bc(n)%implementation - var%bc(n)%ice_restart_file = var_in%bc(n)%ice_restart_file - var%bc(n)%ocean_restart_file = var_in%bc(n)%ocean_restart_file - var%bc(n)%use_atm_pressure = var_in%bc(n)%use_atm_pressure - var%bc(n)%use_10m_wind_speed = var_in%bc(n)%use_10m_wind_speed - var%bc(n)%pass_through_ice = var_in%bc(n)%pass_through_ice - var%bc(n)%mol_wt = var_in%bc(n)%mol_wt - var%bc(n)%num_fields = var_in%bc(n)%num_fields - if (associated(var%bc(n)%field)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - allocate ( var%bc(n)%field(var%bc(n)%num_fields) ) - do m = 1, var%bc(n)%num_fields - if (present(suffix)) then - var%bc(n)%field(m)%name = trim(var_in%bc(n)%field(m)%name) // trim(suffix) - else - var%bc(n)%field(m)%name = var_in%bc(n)%field(m)%name - endif - var%bc(n)%field(m)%long_name = var_in%bc(n)%field(m)%long_name - var%bc(n)%field(m)%units = var_in%bc(n)%field(m)%units - var%bc(n)%field(m)%may_init = var_in%bc(n)%field(m)%may_init - var%bc(n)%field(m)%mean = var_in%bc(n)%field(m)%mean - if (associated(var%bc(n)%field(m)%values)) then - write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated' - call mpp_error(FATAL, trim(error_msg)) - endif - - ! Note that this may be allocating a zero-sized array, which is legal in Fortran. - allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) ) - var%bc(n)%field(m)%values(:,:,:) = 0.0 - enddo - enddo - endif - end subroutine CT_spawn_3d_3d - - - !> @brief Copy all elements of coupler_2d_bc_type. - !! Do a direct copy of the data in all elements of one - !! coupler_2d_bc_type into another. Both must have the same array sizes. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "bc_index must be present if field_index is present." - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index,& - & exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, "CT_copy_data_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, "CT_copy_data_2d: field_index is present and exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - - n1 = 1 - n2 = var_in%num_bcs - if (present(bc_index)) then - n1 = bc_index - n2 = bc_index - endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))& - & call mpp_error(FATAL, "CT_copy_data_2d: There is an i-direction computational domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))& - & call mpp_error(FATAL, "CT_copy_data_2d: There is a j-direction computational domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc - j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type))& - & copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type))& - & copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice))& - & copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var%bc(n)%num_fields - if (present(field_index)) then - if (m /= field_index) cycle - endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo - do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo - enddo - endif - enddo - enddo - end subroutine CT_copy_data_2d - - !> @brief Copy all elements of coupler_3d_bc_type - !! - !! Do a direct copy of the data in all elements of one - !! coupler_3d_bc_type into another. Both must have the same array sizes. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "bc_index must be present if field_index is present." - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "There is an k-direction computational domain size mismatch." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive k-direction halo size for the input structure." - subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index,& - & exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs) & - call mpp_error(FATAL, "CT_copy_data_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, "CT_copy_data_3d: field_index is present and exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - - n1 = 1 - n2 = var_in%num_bcs - if (present(bc_index)) then - n1 = bc_index - n2 = bc_index - endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))& - & call mpp_error(FATAL, "CT_copy_data_3d: There is an i-direction computational domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))& - & call mpp_error(FATAL, "CT_copy_data_3d: There is a j-direction computational domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks))& - & call mpp_error(FATAL, "CT_copy_data_3d: There is a k-direction computational domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc - j_off = var_in%jsc - var%jsc - k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type))& - & copy_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type))& - & copy_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice))& - & copy_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then - if (m /= field_index) cycle - endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke - do j=var%jsc-halo,var%jec+halo - do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) - enddo - enddo - enddo - endif - enddo - enddo - end subroutine CT_copy_data_3d - - !> @brief Copy all elements of coupler_2d_bc_type to coupler_3d_bc_type - !! - !! Do a direct copy of the data in all elements of one coupler_2d_bc_type into a - !! coupler_3d_bc_type. Both must have the same array sizes for the first two dimensions, while - !! the extend of the 3rd dimension that is being filled may be specified via optional arguments.. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "bc_index must be present if field_index is present." - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index,& - & exclude_flux_type, only_flux_type, pass_through_ice,& - & ind3_start, ind3_end) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy - type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this copy. - logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose - !! value of pass_through ice matches this - integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd - !! index of the 3d type to fill in. - integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd - !! index of the 3d type to fill in. - - logical :: copy_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, ks, ke - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: field_index is present and exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_copy_data_2d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - - n1 = 1 - n2 = var_in%num_bcs - if (present(bc_index)) then - n1 = bc_index - n2 = bc_index - endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: There is an i-direction computational domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: There is a j-direction computational domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))& - & call mpp_error(FATAL, "CT_copy_data_2d_3d: Excessive j-direction halo size for the output structure.") - endif - - i_off = var_in%isc - var%isc - j_off = var_in%jsc - var%jsc - do n = n1, n2 - copy_bc = .true. - if (copy_bc .and. present(exclude_flux_type))& - & copy_bc = .not.(trim(var_in%bc(n)%flux_type) == trim(exclude_flux_type)) - if (copy_bc .and. present(only_flux_type))& - & copy_bc = (trim(var_in%bc(n)%flux_type) == trim(only_flux_type)) - if (copy_bc .and. present(pass_through_ice))& - & copy_bc = (pass_through_ice .eqv. var_in%bc(n)%pass_through_ice) - if (.not.copy_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then - if (m /= field_index) cycle - endif - if ( associated(var%bc(n)%field(m)%values) ) then - ks = var%ks - if (present(ind3_start)) ks = max(ks, ind3_start) - ke = var%ke - if (present(ind3_end)) ke = max(ke, ind3_end) - do k=ks,ke - do j=var%jsc-halo,var%jec+halo - do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo - enddo - enddo - endif - enddo - enddo - end subroutine CT_copy_data_2d_3d - - - !> @brief Redistribute the data in all elements of a coupler_2d_bc_type - !! - !! Redistributes the data in all elements of one coupler_2d_bc_type - !! into another, which may be on different processors with a different decomposition. - !! - !! @throw FATAL, "Mismatch in num_bcs in CT_copy_data_2d." - !! @throw FATAL, "Mismatch in the total number of fields in CT_redistribute_data_2d." - subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:) :: null_ptr2D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. - if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 ; fc_out = 0 - if (do_in) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo - enddo - endif - if (fc_in == 0) do_in = .false. - if (do_out) then - do n = 1, var_out%num_bcs - do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo - enddo - endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL,& - & "Mismatch in num_bcs in CT_copy_data_2d.") - if (fc_in /= fc_out) call mpp_error(FATAL,& - & "Mismatch in the total number of fields in CT_redistribute_data_2d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv.& - & associated(var_out%bc(n)%field(m)%values) ) & - call mpp_error(FATAL,& - & "Mismatch in which fields are associated in CT_redistribute_data_2d.") - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values,& - & domain_out, var_out%bc(n)%field(m)%values,& - & complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo - enddo - elseif (do_in) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values,& - & domain_out, null_ptr2D,& - & complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo - enddo - elseif (do_out) then - do n = 1, var_out%num_bcs - do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr2D,& - & domain_out, var_out%bc(n)%field(m)%values,& - & complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo - enddo - endif - end subroutine CT_redistribute_data_2d - - !> @brief Redistributes the data in all elements of one coupler_2d_bc_type - !! - !! Redistributes the data in all elements of one coupler_2d_bc_type into another, which may be on - !! different processors with a different decomposition. - subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy (intent in) - type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure - type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) - type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure - logical, optional, intent(in) :: complete !< If true, complete the updates - - real, pointer, dimension(:,:,:) :: null_ptr3D => NULL() - logical :: do_in, do_out, do_complete - integer :: m, n, fc, fc_in, fc_out - - do_complete = .true. - if (present(complete)) do_complete = complete - - ! Figure out whether this PE has valid input or output fields or both. - do_in = var_in%set - do_out = var_out%set - - fc_in = 0 - fc_out = 0 - if (do_in) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if (associated(var_in%bc(n)%field(m)%values)) fc_in = fc_in + 1 - enddo - enddo - endif - if (fc_in == 0) do_in = .false. - if (do_out) then - do n = 1, var_out%num_bcs - do m = 1, var_out%bc(n)%num_fields - if (associated(var_out%bc(n)%field(m)%values)) fc_out = fc_out + 1 - enddo - enddo - endif - if (fc_out == 0) do_out = .false. - - if (do_in .and. do_out) then - if (var_in%num_bcs /= var_out%num_bcs) call mpp_error(FATAL,& - & "Mismatch in num_bcs in CT_copy_data_3d.") - if (fc_in /= fc_out) call mpp_error(FATAL,& - & "Mismatch in the total number of fields in CT_redistribute_data_3d.") - endif - - if (.not.(do_in .or. do_out)) return - - fc = 0 - if (do_in .and. do_out) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) .neqv.& - & associated(var_out%bc(n)%field(m)%values) )& - & call mpp_error(FATAL,& - & "Mismatch in which fields are associated in CT_redistribute_data_3d.") - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values,& - & domain_out, var_out%bc(n)%field(m)%values,& - & complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo - enddo - elseif (do_in) then - do n = 1, var_in%num_bcs - do m = 1, var_in%bc(n)%num_fields - if ( associated(var_in%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, var_in%bc(n)%field(m)%values,& - & domain_out, null_ptr3D,& - & complete=(do_complete.and.(fc==fc_in)) ) - endif - enddo - enddo - elseif (do_out) then - do n = 1, var_out%num_bcs - do m = 1, var_out%bc(n)%num_fields - if ( associated(var_out%bc(n)%field(m)%values) ) then - fc = fc + 1 - call mpp_redistribute(domain_in, null_ptr3D,& - & domain_out, var_out%bc(n)%field(m)%values,& - & complete=(do_complete.and.(fc==fc_out)) ) - endif - enddo - enddo - endif - end subroutine CT_redistribute_data_3d - - !> @brief Rescales the fields in the fields in the elements of a coupler_2d_bc_type !! !! Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. - subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index,& + subroutine CT_RESCALE_DATA_2D_(var, scale, halo_size, bc_index, field_index,& & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + real(FMS_CP_KIND_), intent(in) :: scale !< A scaling factor to multiply fields by integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or !! the full arrays if scale is 0. integer, optional, intent(in) :: bc_index !< The index of the boundary condition @@ -1754,16 +115,16 @@ contains endif enddo enddo - end subroutine CT_rescale_data_2d + end subroutine CT_RESCALE_DATA_2D_ !> @brief Rescales the fields in the elements of a coupler_3d_bc_type !! !! This subroutine rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a !! factor scale. If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. - subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index,& + subroutine CT_RESCALE_DATA_3D_(var, scale, halo_size, bc_index, field_index,& & exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + real(FMS_CP_KIND_), intent(in) :: scale !< A scaling factor to multiply fields by integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or !! the full arrays if scale is 0. integer, optional, intent(in) :: bc_index !< The index of the boundary condition @@ -1841,234 +202,14 @@ contains do j=var%jsc-halo,var%jec+halo do i=var%isc-halo,var%iec+halo var%bc(n)%field(m)%values(i,j,k) = scale * var%bc(n)%field(m)%values(i,j,k) - enddo - enddo - enddo - endif - endif - enddo - enddo - end subroutine CT_rescale_data_3d - - - !> @brief Increment data in all elements of one coupler_2d_bc_type - !! - !! Do a direct increment of the data in all elements of one coupler_2d_bc_type into another. Both - !! must have the same array sizes. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "bc_index must be present if field_index is present." - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index,& - & scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types - !! of fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, m, n, n1, n2, halo, i_off, j_off - - scale = 1.0 - if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 - if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then - if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, "CT_increment_data_2d_2d: field_index is present and exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_2d_2d: bc_index must be present if field_index is present.") - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - - n1 = 1 - n2 = var_in%num_bcs - if (present(bc_index)) then - n1 = bc_index - n2 = bc_index - endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))& - & call mpp_error(FATAL, "CT_increment_data_2d: There is an i-direction computational domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))& - & call mpp_error(FATAL, "CT_increment_data_2d: There is a j-direction computational domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))& - & call mpp_error(FATAL, "CT_increment_data_2d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))& - & call mpp_error(FATAL, "CT_increment_data_2d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc - j_off = var_in%jsc - var%jsc - endif - - do n = n1, n2 - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type))& - & increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type))& - & increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice))& - & increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then - if (m /= field_index) cycle - endif - if ( associated(var%bc(n)%field(m)%values) ) then - do j=var%jsc-halo,var%jec+halo - do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j) = sc_prev * var%bc(n)%field(m)%values(i,j) +& - & scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off) - enddo - enddo - endif - enddo - enddo - end subroutine CT_increment_data_2d_2d - - - !> @brief Increment data in all elements of one coupler_3d_bc_type - !! - !! Do a direct increment of the data in all elements of one coupler_3d_bc_type into another. Both - !! must have the same array sizes. - !! - !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs." - !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%bc(bc_incdx)%name" - !! @throw FATAL, "bc_index must be present if field_index is present." - !! @throw FATAL, "There is an i-direction computational domain size mismatch." - !! @throw FATAL, "There is an j-direction computational domain size mismatch." - !! @throw FATAL, "There is an k-direction computational domain size mismatch." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive i-direction halo size for the input structure." - !! @throw FATAL, "Excessive k-direction halo size for the input structure." - subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index,& - & scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) - type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented - integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default - integer, optional, intent(in) :: bc_index !< The index of the boundary condition - !! that is being copied - integer, optional, intent(in) :: field_index !< The index of the field in the - !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types - !! of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of - !! fluxes to include from this increment. - logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose - !! value of pass_through ice matches this - - real :: scale, sc_prev - logical :: increment_bc - integer :: i, j, k, m, n, n1, n2, halo, i_off, j_off, k_off - - scale = 1.0 - if (present(scale_factor)) scale = scale_factor - sc_prev = 1.0 - if (present(scale_prev)) sc_prev = scale_prev - - if (present(bc_index)) then - if (bc_index > var_in%num_bcs)& - & call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index is present and exceeds var_in%num_bcs.") - if (present(field_index)) then ; if (field_index > var_in%bc(bc_index)%num_fields)& - & call mpp_error(FATAL, "CT_increment_data_3d_3d: field_index is present and exceeds num_fields for" //& - & trim(var_in%bc(bc_index)%name) ) - endif - elseif (present(field_index)) then - call mpp_error(FATAL, "CT_increment_data_3d_3d: bc_index must be present if field_index is present.") - endif - - halo = 0 - if (present(halo_size)) halo = halo_size - - n1 = 1 - n2 = var_in%num_bcs - if (present(bc_index)) then - n1 = bc_index - n2 = bc_index - endif - - if (n2 >= n1) then - ! A more consciencious implementation would include a more descriptive error messages. - if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))& - & call mpp_error(FATAL, "CT_increment_data_3d: There is an i-direction computational domain size mismatch.") - if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))& - & call mpp_error(FATAL, "CT_increment_data_3d: There is a j-direction computational domain size mismatch.") - if ((var_in%ke-var_in%ks) /= (var%ke-var%ks))& - & call mpp_error(FATAL, "CT_increment_data_3d: There is a k-direction computational domain size mismatch.") - if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))& - & call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the input structure.") - if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))& - & call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the input structure.") - if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))& - & call mpp_error(FATAL, "CT_increment_data_3d: Excessive i-direction halo size for the output structure.") - if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))& - & call mpp_error(FATAL, "CT_increment_data_3d: Excessive j-direction halo size for the output structure.") - - i_off = var_in%isc - var%isc - j_off = var_in%jsc - var%jsc - k_off = var_in%ks - var%ks - endif - - do n = n1, n2 - increment_bc = .true. - if (increment_bc .and. present(exclude_flux_type))& - & increment_bc = .not.(trim(var%bc(n)%flux_type) == trim(exclude_flux_type)) - if (increment_bc .and. present(only_flux_type))& - & increment_bc = (trim(var%bc(n)%flux_type) == trim(only_flux_type)) - if (increment_bc .and. present(pass_through_ice))& - & increment_bc = (pass_through_ice .eqv. var%bc(n)%pass_through_ice) - if (.not.increment_bc) cycle - - do m = 1, var_in%bc(n)%num_fields - if (present(field_index)) then - if (m /= field_index) cycle - endif - if ( associated(var%bc(n)%field(m)%values) ) then - do k=var%ks,var%ke - do j=var%jsc-halo,var%jec+halo - do i=var%isc-halo,var%iec+halo - var%bc(n)%field(m)%values(i,j,k) = sc_prev * var%bc(n)%field(m)%values(i,j,k) +& - & scale * var_in%bc(n)%field(m)%values(i+i_off,j+j_off,k+k_off) + enddo enddo enddo - enddo + endif endif enddo enddo - end subroutine CT_increment_data_3d_3d + end subroutine CT_RESCALE_DATA_3D_ !> @brief Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a !! coupler_3d_bc_type @@ -2087,10 +228,10 @@ contains !! @throw FATAL, "Excessive i-direction halo size for the input structure." !! @throw FATAL, "weights array must be the i-size of a computational or data domain." !! @throw FATAL, "weights array must be the j-size of a computational or data domain." - subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, field_index,& + subroutine CT_INCREMENT_DATA_2D_3D_(var_in, weights, var, halo_size, bc_index, field_index,& & scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type - real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + real(FMS_CP_KIND_), dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to !! increment the 2d-data. There is no renormalization, !! so if the weights do not sum to 1 in the 3rd dimension !! there may be adverse consequences! @@ -2100,8 +241,8 @@ contains !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added - real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types !! of fluxes to exclude from this increment. character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types @@ -2109,7 +250,7 @@ contains logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this - real :: scale, sc_prev + real(FMS_CP_KIND_) :: scale, sc_prev logical :: increment_bc integer :: i, j, k, m, n, n1, n2, halo integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions. @@ -2212,7 +353,7 @@ contains endif enddo enddo - end subroutine CT_increment_data_2d_3d + end subroutine CT_INCREMENT_DATA_2D_3D_ !> @brief Extract a 2d field from a coupler_2d_bc_type !! @@ -2230,17 +371,17 @@ contains !! @throw FATAL, "There is an j-direction computational domain size mismatch." !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" - subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out,& + subroutine CT_EXTRACT_DATA_2D_(var_in, bc_index, field_index, array_out,& & scale_factor, halo_size, idim, jdim) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied integer, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2253,7 +394,7 @@ contains & '==>Error from coupler_types_mod (CT_extract_data_2d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, halo, i_off, j_off if (bc_index <= 0) then @@ -2348,7 +489,7 @@ contains array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j) enddo enddo - end subroutine CT_extract_data_2d + end subroutine CT_EXTRACT_DATA_2D_ !> @brief Extract a single k-level of a 3d field from a coupler_3d_bc_type !! @@ -2367,7 +508,7 @@ contains !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The extracted k-index of 'k' is outside of the valid range of 'ks' to 'ke'" - subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out,& + subroutine CT_EXTRACT_DATA_3D_2D_(var_in, bc_index, field_index, k_in, array_out,& & scale_factor, halo_size, idim, jdim) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract integer, intent(in) :: bc_index !< The index of the boundary condition @@ -2375,10 +516,10 @@ contains integer, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied integer, intent(in) :: k_in !< The k-index to extract - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2390,7 +531,7 @@ contains & '==>Error from coupler_types_mod (CT_extract_data_3d_2d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, halo, i_off, j_off if (bc_index <= 0) then @@ -2491,7 +632,7 @@ contains array_out(i+i_off,j+j_off) = scale * var_in%bc(bc_index)%field(field_index)%values(i,j,k_in) enddo enddo - end subroutine CT_extract_data_3d_2d + end subroutine CT_EXTRACT_DATA_3D_2D_ !> @brief Extract single 3d field from a coupler_3d_bc_type !! @@ -2510,17 +651,17 @@ contains !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with k-dimension size 'n' does not match the data of size 'd'" - subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out,& + subroutine CT_EXTRACT_DATA_3D_(var_in, bc_index, field_index, array_out,& & scale_factor, halo_size, idim, jdim) type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied integer, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - real, dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2533,7 +674,7 @@ contains & '==>Error from coupler_types_mod (CT_extract_data_3d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, k, halo, i_off, j_off, k_off if (bc_index <= 0) then @@ -2638,7 +779,7 @@ contains enddo enddo enddo - end subroutine CT_extract_data_3d + end subroutine CT_EXTRACT_DATA_3D_ !> @brief Set single 2d field in coupler_3d_bc_type !! @@ -2656,9 +797,9 @@ contains !! @throw FATAL, "There is an j-direction computational domain size mismatch." !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" - subroutine CT_set_data_2d(array_in, bc_index, field_index, var,& + subroutine CT_SET_DATA_2D_(array_in, bc_index, field_index, var,& & scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition @@ -2666,7 +807,7 @@ contains integer, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2678,7 +819,7 @@ contains & '==>Error from coupler_types_mod (CT_set_data_2d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, halo, i_off, j_off if (bc_index <= 0) return @@ -2770,7 +911,7 @@ contains var%bc(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off) enddo enddo - end subroutine CT_set_data_2d + end subroutine CT_SET_DATA_2D_ !> @brief Set one k-level of a single 3d field in a coupler_3d_bc_type !! @@ -2790,9 +931,9 @@ contains !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The k-index of 'k' is outside of the valid range of 'ks' to 'ke'" - subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, var,& + subroutine CT_SET_DATA_2D_3D_(array_in, bc_index, field_index, k_out, var,& & scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition @@ -2801,7 +942,7 @@ contains !! boundary condition that is being copied integer, intent(in) :: k_out !< The k-index to set type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2814,7 +955,7 @@ contains & '==>Error from coupler_types_mod (CT_set_data_3d_2d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, halo, i_off, j_off if (bc_index <= 0) return @@ -2912,7 +1053,7 @@ contains var%bc(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off) enddo enddo - end subroutine CT_set_data_2d_3d + end subroutine CT_SET_DATA_2D_3D_ !> @brief Set a single 3d field in a coupler_3d_bc_type !! @@ -2931,9 +1072,9 @@ contains !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'" !! @throw FATAL, "The target array with K-dimension size 'n' is too small to match the data of size 'd'" - subroutine CT_set_data_3d(array_in, bc_index, field_index, var,& + subroutine CT_SET_DATA_3D_(array_in, bc_index, field_index, var,& & scale_factor, halo_size, idim, jdim) - real, dimension(1:,1:,1:), intent(in) :: array_in !< The source array for the field; its size + real(FMS_CP_KIND_), dimension(1:,1:,1:), intent(in) :: array_in !< The source array for the field; its size !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition @@ -2941,7 +1082,7 @@ contains integer, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -2954,7 +1095,7 @@ contains & '==>Error from coupler_types_mod (CT_set_data_3d):' character(len=400) :: error_msg - real :: scale + real(FMS_CP_KIND_) :: scale integer :: i, j, k, halo, i_off, j_off, k_off if (bc_index <= 0) return @@ -3056,1019 +1197,4 @@ contains enddo enddo enddo - end subroutine CT_set_data_3d - - - !! @brief Register the diagnostics of a coupler_2d_bc_type - !! - !! @throw FATAL, "axes has less than 2 elements" - subroutine CT_set_diags_2d(var, diag_name, axes, time) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 2) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - & '(coupler_types_set_diags_3d): axes has less than 2 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name,& - & var%bc(n)%field(m)%name, axes(1:2), Time,& - & var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units) - enddo - enddo - end subroutine CT_set_diags_2d - - !> @brief Register the diagnostics of a coupler_3d_bc_type. - !! - !! @throw FATAL, "axes has less than 3 elements" - subroutine CT_set_diags_3d(var, diag_name, axes, time) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then - !! don't register the fields - integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration - type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - - integer :: m, n - - if (diag_name == ' ') return - - if (size(axes) < 3) then - call mpp_error(FATAL, '==>Error from coupler_types_mod' //& - & '(coupler_types_set_diags_3d): axes has less than 3 elements') - endif - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_diag = register_diag_field(diag_name,& - & var%bc(n)%field(m)%name, axes(1:3), Time,& - & var%bc(n)%field(m)%long_name, var%bc(n)%field(m)%units ) - enddo - enddo - end subroutine CT_set_diags_3d - - - !> @brief Write out all diagnostics of elements of a coupler_2d_bc_type - subroutine CT_send_data_2d(var, Time) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - if (var%bc(n)%field(m)%id_diag > 0) then - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - endif - enddo - enddo - end subroutine CT_send_data_2d - - !> @brief Write out all diagnostics of elements of a coupler_3d_bc_type - subroutine CT_send_data_3d(var, Time) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - logical :: used - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - if (var%bc(n)%field(m)%id_diag > 0) then - used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time) - endif - enddo - enddo - end subroutine CT_send_data_3d - - !! @brief Register the fields in a coupler_2d_bc_type to be saved in restart files - !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files - !! specified in the field table. - subroutine CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, to_read, ocean_restart, directory) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(FmsNetcdfDomainFile_t), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, intent(in) :: to_read !< Flag indicating if reading/writing a file - logical, optional,intent(in) :: ocean_restart !< If true, use the ocean restart file name. - character(len=*),optional,intent(in) :: directory !< Directory where to open the file - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - character(len=20), allocatable, dimension(:) :: dim_names !< Array of dimension names - character(len=20) :: io_type !< flag indicating io type: "read" "overwrite" - logical, dimension(max(1,var%num_bcs)) :: file_is_open !< flag indicating if file is open - character(len=20) :: dir !< Directory where to open the file - - ocn_rest = .true. - if (present(ocean_restart)) ocn_rest = ocean_restart - - if (present(directory)) dir = trim(directory) - - if (to_read) then - io_type = "read" - if (.not. present(directory)) dir = "INPUT/" - else - io_type = "overwrite" - if (.not. present(directory)) dir = "RESTART/" - endif - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - allocate(bc_rest_files(num_rest_files)) - - !< Open the files - do n = 1, num_rest_files - file_is_open(n) = open_file(bc_rest_files(n), trim(dir)//rest_file_names(n), io_type, mpp_domain, & - & is_restart=.true.) - if (file_is_open(n)) then - call register_axis_wrapper(bc_rest_files(n), to_read=to_read) - endif - enddo - - ! Register the fields with the restart files - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%fms2_io_rest_type => bc_rest_files(f) - - do m = 1, var%bc(n)%num_fields - if (file_is_open(f)) then - if( to_read .and. variable_exists(bc_rest_files(f), var%bc(n)%field(m)%name)) then - !< If reading get the dimension names from the file - allocate(dim_names(get_variable_num_dimensions(bc_rest_files(f), var%bc(n)%field(m)%name))) - call get_variable_dimension_names(bc_rest_files(f), & - & var%bc(n)%field(m)%name, dim_names) - else - !< If writing use dummy dimension names - allocate(dim_names(3)) - dim_names(1) = "xaxis_1" - dim_names(2) = "yaxis_1" - dim_names(3) = "Time" - endif !< to_read - - call register_restart_field(bc_rest_files(f),& - & var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, dim_names, & - & is_optional=var%bc(n)%field(m)%may_init ) - - deallocate(dim_names) - endif !< If file_is_open - enddo !< num_fields - enddo !< num_bcs - - end subroutine CT_register_restarts_2d - - !< If reading a restart, register the dimensions that are in the file - subroutine register_axis_wrapper_read(fileobj) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< Domain decomposed fileobj - - character(len=20), dimension(:), allocatable :: file_dim_names !< Array of dimension names - integer :: i !< No description - integer :: dim_size !< Size of the dimension - integer :: ndims !< Number of dimensions in the file - logical :: is_domain_decomposed !< Flag indication if domain decomposed - character(len=1) :: buffer !< string buffer - - ndims = get_num_dimensions(fileobj) - allocate(file_dim_names(ndims)) - - call get_dimension_names(fileobj, file_dim_names) - - do i = 1, ndims - is_domain_decomposed = .false. - - !< Check if the dimension is also a variable - if (variable_exists(fileobj, file_dim_names(i))) then - - !< If the variable exists look for the "cartesian_axis" or "axis" variable attribute - if (variable_att_exists(fileobj, file_dim_names(i), "axis")) then - call get_variable_attribute(fileobj, file_dim_names(i), "axis", buffer) - - !< If the attribute exists and it is "x" or "y" register it as a domain decomposed dimension - if (lowercase(buffer) .eq. "x" .or. lowercase(buffer) .eq. "y" ) then - is_domain_decomposed = .true. - call register_axis(fileobj, file_dim_names(i), buffer) - endif - - else if (variable_att_exists(fileobj, file_dim_names(i), "cartesian_axis")) then - call get_variable_attribute(fileobj, file_dim_names(i), "cartesian_axis", buffer) - - !< If the attribute exists and it "x" or "y" register it as a domain decomposed dimension - if (lowercase(buffer) .eq. "x" .or. lowercase(buffer) .eq. "y" ) then - is_domain_decomposed = .true. - call register_axis(fileobj, file_dim_names(i), buffer) - endif - - endif !< If variable attribute exists - endif !< If variable exists - - if (.not. is_domain_decomposed) then - call get_dimension_size(fileobj, file_dim_names(i), dim_size) - call register_axis(fileobj, file_dim_names(i), dim_size) - endif - - end do - - end subroutine register_axis_wrapper_read - - !< If writting a restart, register the variables with dummy axis names - subroutine register_axis_wrapper_write(fileobj, nz) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< Domain decomposed fileobj - integer, intent(in), optional :: nz !< length of the z dimension - - character(len=20) :: dim_names(4) !< Array of dimension names - - dim_names(1) = "xaxis_1" - dim_names(2) = "yaxis_1" - - call register_axis(fileobj, dim_names(1), "x") - call register_axis(fileobj, dim_names(2), "y") - - !< If nz is present register a zaxis - if (.not. present(nz)) then - dim_names(3) = "Time" - call register_axis(fileobj, dim_names(3), unlimited) - else - dim_names(3) = "zaxis_1" - dim_names(4) = "Time" - - call register_axis(fileobj, dim_names(3), nz) - call register_axis(fileobj, dim_names(4), unlimited) - endif !< if (.not. present(nz)) - - !< Add the dimension names as variable so that the combiner can work correctly - call register_field(fileobj, dim_names(1), "double", (/dim_names(1)/)) - call register_variable_attribute(fileobj, dim_names(1), "axis", "X", str_len=1) - - call register_field(fileobj, dim_names(2), "double", (/dim_names(2)/)) - call register_variable_attribute(fileobj, dim_names(2), "axis", "Y", str_len=1) - - end subroutine register_axis_wrapper_write - - subroutine register_axis_wrapper(fileobj, to_read, nz) - type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< Domain decomposed fileobj - logical, intent(in) :: to_read !< Flag indicating if reading file - integer, intent(in), optional :: nz !< length of the z dimension - - if (to_read) then - call register_axis_wrapper_read(fileobj) - else - call register_axis_wrapper_write(fileobj, nz) - endif - - end subroutine register_axis_wrapper - - !! @brief Register the fields in a coupler_3d_bc_type to be saved in restart files - !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files - !! specified in the field table. - subroutine CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, to_read, ocean_restart, directory) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(FmsNetcdfDomainFile_t), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, intent(in) :: to_read !< Flag indicating if reading/writing a file - logical, optional,intent(in) :: ocean_restart !< If true, use the ocean restart file name. - character(len=*),optional,intent(in) :: directory !< Directory where to open the file - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - character(len=20), allocatable, dimension(:) :: dim_names !< Array of dimension names - character(len=20) :: io_type !< flag indicating io type: "read" "overwrite" - logical, dimension(max(1,var%num_bcs)) :: file_is_open !< Flag indicating if file is open - character(len=20) :: dir !< Directory where to open the file - integer :: nz !< Length of the z direction of each file - - ocn_rest = .true. - if (present(ocean_restart)) ocn_rest = ocean_restart - - if (present(directory)) dir = trim(directory) - - if (to_read) then - io_type = "read" - if (.not. present(directory)) dir = "INPUT/" - else - io_type = "overwrite" - if (.not. present(directory)) dir = "RESTART/" - endif - - nz = var%ke - var%ks + 1 !< NOTE: This assumes that the z dimension is the same for every variable - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - allocate(bc_rest_files(num_rest_files)) - - !< Open the files - do n = 1, num_rest_files - file_is_open(n) = open_file(bc_rest_files(n), trim(dir)//rest_file_names(n), io_type, mpp_domain, & - & is_restart=.true.) - if (file_is_open(n)) then - - if (to_read) then - call register_axis_wrapper(bc_rest_files(n), to_read=to_read) - else - call register_axis_wrapper(bc_rest_files(n), to_read=to_read, nz=nz) - endif - endif - enddo - - ! Register the fields with the restart files - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%fms2_io_rest_type => bc_rest_files(f) - - do m = 1, var%bc(n)%num_fields - if (file_is_open(f)) then - if( to_read .and. variable_exists(bc_rest_files(f), var%bc(n)%field(m)%name)) then - !< If reading get the dimension names from the file - allocate(dim_names(get_variable_num_dimensions(bc_rest_files(f), var%bc(n)%field(m)%name))) - call get_variable_dimension_names(bc_rest_files(f), & - & var%bc(n)%field(m)%name, dim_names) - else - !< If writing use dummy dimension names - allocate(dim_names(4)) - dim_names(1) = "xaxis_1" - dim_names(2) = "yaxis_1" - dim_names(3) = "zaxis_1" - dim_names(4) = "Time" - endif !< to_read - - call register_restart_field(bc_rest_files(f),& - & var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, dim_names, & - & is_optional=var%bc(n)%field(m)%may_init ) - deallocate(dim_names) - endif !< If file_is_open - enddo !< num_fields - enddo !< num_bcs - - end subroutine CT_register_restarts_3d - - subroutine CT_restore_state_2d(var, use_fms2_io, directory, all_or_nothing, all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - logical, intent(in) :: use_fms2_io !< This is just to distinguish the interfaces - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. - all_set = .true. - num_fld = 0 - unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. - all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (check_if_open(var%bc(n)%fms2_io_rest_type)) then - var_set = variable_exists(var%bc(n)%fms2_io_rest_type, var%bc(n)%field(m)%name) - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL,& - & "CT_restore_state_2d: test_by_field is true, and "//& - & trim(unset_varname)//" was not read but some other fields in "//& - & trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL,& - & "CT_restore_state_2d: all_or_nothing is true, and "//& - & trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then - if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_2d: all_required is true, but "//& - & trim(unset_varname)//" was not read from its restart file.") - endif - endif - end subroutine CT_restore_state_2d - - !> @brief Read in fields from restart files into a coupler_3d_bc_type - !! - !! This subroutine reads in the fields in a coupler_3d_bc_type that have been saved in restart - !! files. - subroutine CT_restore_state_3d(var, use_fms2_io, directory, all_or_nothing, all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, intent(in) :: use_fms2_io !< This is just to distinguish the interfaces - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. - all_set = .true. - num_fld = 0 - unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. - all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (check_if_open(var%bc(n)%fms2_io_rest_type)) then - var_set = variable_exists(var%bc(n)%fms2_io_rest_type, var%bc(n)%field(m)%name) - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL,& - & "CT_restore_state_3d: test_by_field is true, and "//& - & trim(unset_varname)//" was not read but some other fields in "//& - & trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL,& - & "CT_restore_state_3d: all_or_nothing is true, and "//& - & trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then - if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "CT_restore_state_3d: all_required is true, but "//& - & trim(unset_varname)//" was not read from its restart file.") - endif - endif - end subroutine CT_restore_state_3d - - - !> @brief Potentially override the values in a coupler_2d_bc_type - subroutine CT_data_override_2d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo - enddo - end subroutine CT_data_override_2d - - !> @brief Potentially override the values in a coupler_3d_bc_type - subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time - - integer :: m, n - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - call data_override(gridname, var%bc(n)%field(m)%name, var%bc(n)%field(m)%values, Time) - enddo - enddo - end subroutine CT_data_override_3d - - - !> @brief Write out checksums for the elements of a coupler_2d_bc_type - subroutine CT_write_chksums_2d(var, outunit, name_lead) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - integer(kind=int64) :: chks ! A checksum for the field - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - chks = mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec)) - if(outunit.ne.0) write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), chks - enddo - enddo - end subroutine CT_write_chksums_2d - - !> @brief Write out checksums for the elements of a coupler_3d_bc_type - subroutine CT_write_chksums_3d(var, outunit, name_lead) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics - integer, intent(in) :: outunit !< The index of a open output file - character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names - - character(len=120) :: var_name - integer :: m, n - integer(kind=int64) :: chks ! A checksum for the field - - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - if (present(name_lead)) then - var_name = trim(name_lead)//trim(var%bc(n)%field(m)%name) - else - var_name = trim(var%bc(n)%field(m)%name) - endif - chks = mpp_chksum(var%bc(n)%field(m)%values(var%isc:var%iec,var%jsc:var%jec,:)) - if(outunit.ne.0) write(outunit, '(" CHECKSUM:: ",A40," = ",Z20)') trim(var_name), chks - enddo - enddo - end subroutine CT_write_chksums_3d - - !> @brief Indicate whether a coupler_1d_bc_type has been initialized. - !! @return Logical - logical function CT_initialized_1d(var) - type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - - CT_initialized_1d = var%set - end function CT_initialized_1d - - !> @brief Indicate whether a coupler_2d_bc_type has been initialized. - !! @return Logical - logical function CT_initialized_2d(var) - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - - CT_initialized_2d = var%set - end function CT_initialized_2d - - !> @brief Indicate whether a coupler_3d_bc_type has been initialized. - !! @return Logical - logical function CT_initialized_3d(var) - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed - - CT_initialized_3d = var%set - end function CT_initialized_3d - - !> @brief Deallocate all data associated with a coupler_1d_bc_type - subroutine CT_destructor_1d(var) - type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 - var%set = .false. - end subroutine CT_destructor_1d - - !> @brief Deallocate all data associated with a coupler_2d_bc_type - subroutine CT_destructor_2d(var) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 - var%set = .false. - end subroutine CT_destructor_2d - - !> @brief Deallocate all data associated with a coupler_3d_bc_type - subroutine CT_destructor_3d(var) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed - - integer :: m, n - - if (var%num_bcs > 0) then - do n = 1, var%num_bcs - do m = 1, var%bc(n)%num_fields - deallocate ( var%bc(n)%field(m)%values ) - enddo - deallocate ( var%bc(n)%field ) - enddo - deallocate ( var%bc ) - endif - - var%num_bcs = 0 - var%set = .false. - end subroutine CT_destructor_3d - - !! @brief Register the fields in a coupler_2d_bc_type to be saved in restart files - !! - !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files - !! specified in the field table. -#ifdef use_deprecated_io - subroutine mpp_io_CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. - if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = fms_io_register_restart_field(bc_rest_files(f),& - & rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values,& - & mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - end subroutine mpp_io_CT_register_restarts_2d - - !! @brief Register the fields in a coupler_2d_bc_type to be saved to restart files - !! - !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in the specified - !! restart file. - subroutine mpp_io_CT_register_restarts_to_file_2d(var, file_name, rest_file, mpp_domain, varname_prefix) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing - !! the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = fms_io_register_restart_field(rest_file,& - & file_name, var_name, var%bc(n)%field(m)%values,& - & mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - end subroutine mpp_io_CT_register_restarts_to_file_2d - - !! @brief Register the fields in a coupler_3d_bc_type to be saved to restart files - !! - !! This subroutine registers the fields in a coupler_3d_bc_type to be saved in restart files - !! specified in the field table. - subroutine mpp_io_CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files - integer, intent(out) :: num_rest_files !< The number of restart files to use - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - logical, optional, intent(in) :: ocean_restart !< If true, use the ocean restart file name. - - character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names - character(len=80) :: file_nm - logical :: ocn_rest - integer :: f, n, m - - ocn_rest = .true. - if (present(ocean_restart)) ocn_rest = ocean_restart - - ! Determine the number and names of the restart files - num_rest_files = 0 - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - if (f>num_rest_files) then - num_rest_files = num_rest_files + 1 - rest_file_names(f) = trim(file_nm) - endif - enddo - - if (num_rest_files == 0) return - - ! Register the fields with the restart files - allocate(bc_rest_files(num_rest_files)) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - file_nm = trim(var%bc(n)%ice_restart_file) - if (ocn_rest) file_nm = trim(var%bc(n)%ocean_restart_file) - do f = 1, num_rest_files - if (trim(file_nm) == trim(rest_file_names(f))) exit - enddo - - var%bc(n)%rest_type => bc_rest_files(f) - do m = 1, var%bc(n)%num_fields - var%bc(n)%field(m)%id_rest = fms_io_register_restart_field(bc_rest_files(f),& - & rest_file_names(f), var%bc(n)%field(m)%name, var%bc(n)%field(m)%values,& - & mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - end subroutine mpp_io_CT_register_restarts_3d - - !> @brief Register the fields in a coupler_3d_bc_type to be saved to restart files - !! - !! Registers the fields in a coupler_3d_bc_type to be saved in the specified restart file. - subroutine mpp_io_CT_register_restarts_to_file_3d(var, file_name, rest_file, mpp_domain, varname_prefix) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts - character(len=*), intent(in) :: file_name !< The name of the restart file - type(restart_file_type), pointer :: rest_file !< A (possibly associated) structure describing the restart file - type(domain2D), intent(in) :: mpp_domain !< The FMS domain to use for this registration call - character(len=*), optional, intent(in) :: varname_prefix !< A prefix for the variable name - !! in the restart file, intended to allow - !! multiple BC_type variables to use the - !! same restart files. - - character(len=128) :: var_name - integer :: n, m - - ! Register the fields with the restart file - if (.not.associated(rest_file)) allocate(rest_file) - do n = 1, var%num_bcs - if (var%bc(n)%num_fields <= 0) cycle - - var%bc(n)%rest_type => rest_file - do m = 1, var%bc(n)%num_fields - var_name = trim(var%bc(n)%field(m)%name) - if (present(varname_prefix)) var_name = trim(varname_prefix)//trim(var_name) - var%bc(n)%field(m)%id_rest = fms_io_register_restart_field(rest_file,& - & file_name, var_name, var%bc(n)%field(m)%values,& - & mpp_domain, mandatory=.not.var%bc(n)%field(m)%may_init ) - enddo - enddo - end subroutine mpp_io_CT_register_restarts_to_file_3d - - !> @brief Reads in fields from restart files into a coupler_2d_bc_type - !! - !! This subroutine reads in the fields in a coupler_2d_bc_type that have been saved in restart - !! files. - subroutine mpp_io_CT_restore_state_2d(var, directory, all_or_nothing, all_required, test_by_field) - type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. - all_set = .true. - num_fld = 0 - unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. - all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest,& - & directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL,& - & "mpp_io_CT_restore_state_2d: test_by_field is true, and "//& - & trim(unset_varname)//" was not read but some other fields in "//& - & trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL,& - & "mpp_io_CT_restore_state_2d: all_or_nothing is true, and "//& - & trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then - if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "mpp_io_CT_restore_state_2d: all_required is true, but "//& - & trim(unset_varname)//" was not read from its restart file.") - endif - endif - end subroutine mpp_io_CT_restore_state_2d - - !> @brief Read in fields from restart files into a coupler_3d_bc_type - !! - !! This subroutine reads in the fields in a coupler_3d_bc_type that have been saved in restart - !! files. - subroutine mpp_io_CT_restore_state_3d(var, directory, all_or_nothing, all_required, test_by_field) - type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to restore from restart files - character(len=*), optional, intent(in) :: directory !< A directory where the restart files should - !! be found. The default for FMS is 'INPUT'. - logical, optional, intent(in) :: all_or_nothing !< If true and there are non-mandatory - !! restart fields, it is still an error if some - !! fields are read successfully but others are not. - logical, optional, intent(in) :: all_required !< If true, all fields must be successfully - !! read from the restart file, even if they were - !! registered as not mandatory. - logical, optional, intent(in) :: test_by_field !< If true, all or none of the variables - !! in a single field must be read successfully. - - integer :: n, m, num_fld - character(len=80) :: unset_varname - logical :: any_set, all_set, all_var_set, any_var_set, var_set - - any_set = .false. - all_set = .true. - num_fld = 0 - unset_varname = "" - - do n = 1, var%num_bcs - any_var_set = .false. - all_var_set = .true. - do m = 1, var%bc(n)%num_fields - var_set = .false. - if (var%bc(n)%field(m)%id_rest > 0) then - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - if (.not.var_set) then - call restore_state(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest,& - & directory=directory, nonfatal_missing_files=.true.) - var_set = query_initialized(var%bc(n)%rest_type, var%bc(n)%field(m)%id_rest) - endif - endif - - if (.not.var_set) unset_varname = trim(var%bc(n)%field(m)%name) - - if (var_set) any_set = .true. - if (all_set) all_set = var_set - if (var_set) any_var_set = .true. - if (all_var_set) all_var_set = var_set - enddo - - num_fld = num_fld + var%bc(n)%num_fields - if ((var%bc(n)%num_fields > 0) .and. present(test_by_field)) then - if (test_by_field .and. (all_var_set .neqv. any_var_set)) call mpp_error(FATAL,& - & "mpp_io_CT_restore_state_3d: test_by_field is true, and "//& - & trim(unset_varname)//" was not read but some other fields in "//& - & trim(trim(var%bc(n)%name))//" were.") - endif - enddo - - if ((num_fld > 0) .and. present(all_or_nothing)) then - if (all_or_nothing .and. (all_set .neqv. any_set)) call mpp_error(FATAL,& - & "mpp_io_CT_restore_state_3d: all_or_nothing is true, and "//& - & trim(unset_varname)//" was not read but some other fields were.") - endif - - if (present(all_required)) then - if (all_required .and. .not.all_set) then - call mpp_error(FATAL, "mpp_io_CT_restore_state_3d: all_required is true, but "//& - & trim(unset_varname)//" was not read from its restart file.") - endif - endif - end subroutine mpp_io_CT_restore_state_3d -#endif -end module coupler_types_mod -!> @} -! close documentation grouping + end subroutine CT_SET_DATA_3D_ diff --git a/coupler/include/coupler_types_r4.fh b/coupler/include/coupler_types_r4.fh new file mode 100644 index 0000000000..cf60012e80 --- /dev/null +++ b/coupler/include/coupler_types_r4.fh @@ -0,0 +1,50 @@ +!*********************************************************************** +!* 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 FMS_CP_KIND_ +#define FMS_CP_KIND_ r4_kind + +#undef CT_RESCALE_DATA_2D_ +#define CT_RESCALE_DATA_2D_ CT_rescale_data_2d_r4 + +#undef CT_RESCALE_DATA_3D_ +#define CT_RESCALE_DATA_3D_ CT_rescale_data_3d_r4 + +#undef CT_INCREMENT_DATA_2D_3D_ +#define CT_INCREMENT_DATA_2D_3D_ CT_increment_data_2d_3d_r4 + +#undef CT_EXTRACT_DATA_2D_ +#define CT_EXTRACT_DATA_2D_ CT_extract_data_2d_r4 + +#undef CT_EXTRACT_DATA_3D_ +#define CT_EXTRACT_DATA_3D_ CT_extract_data_3d_r4 + +#undef CT_EXTRACT_DATA_3D_2D_ +#define CT_EXTRACT_DATA_3D_2D_ CT_extract_data_3d_2d_r4 + +#undef CT_SET_DATA_2D_ +#define CT_SET_DATA_2D_ CT_set_data_2d_r4 + +#undef CT_SET_DATA_2D_3D_ +#define CT_SET_DATA_2D_3D_ CT_set_data_2d_3d_r4 + +#undef CT_SET_DATA_3D_ +#define CT_SET_DATA_3D_ CT_set_data_3d_r4 + +#include "include/coupler_types.inc" \ No newline at end of file diff --git a/coupler/include/coupler_types_r8.fh b/coupler/include/coupler_types_r8.fh new file mode 100644 index 0000000000..2ebf0ba480 --- /dev/null +++ b/coupler/include/coupler_types_r8.fh @@ -0,0 +1,50 @@ +!*********************************************************************** +!* 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 FMS_CP_KIND_ +#define FMS_CP_KIND_ r8_kind + +#undef CT_RESCALE_DATA_2D_ +#define CT_RESCALE_DATA_2D_ CT_rescale_data_2d_r8 + +#undef CT_RESCALE_DATA_3D_ +#define CT_RESCALE_DATA_3D_ CT_rescale_data_3d_r8 + +#undef CT_INCREMENT_DATA_2D_3D_ +#define CT_INCREMENT_DATA_2D_3D_ CT_increment_data_2d_3d_r8 + +#undef CT_EXTRACT_DATA_2D_ +#define CT_EXTRACT_DATA_2D_ CT_extract_data_2d_r8 + +#undef CT_EXTRACT_DATA_3D_ +#define CT_EXTRACT_DATA_3D_ CT_extract_data_3d_r8 + +#undef CT_EXTRACT_DATA_3D_2D_ +#define CT_EXTRACT_DATA_3D_2D_ CT_extract_data_3d_2d_r8 + +#undef CT_SET_DATA_2D_ +#define CT_SET_DATA_2D_ CT_set_data_2d_r8 + +#undef CT_SET_DATA_2D_3D_ +#define CT_SET_DATA_2D_3D_ CT_set_data_2d_3d_r8 + +#undef CT_SET_DATA_3D_ +#define CT_SET_DATA_3D_ CT_set_data_3d_r8 + +#include "include/coupler_types.inc" \ No newline at end of file diff --git a/coupler/include/ensemble_manager.inc b/coupler/include/ensemble_manager.inc deleted file mode 100644 index 257dfed54e..0000000000 --- a/coupler/include/ensemble_manager.inc +++ /dev/null @@ -1,423 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup ensemble_manager_mod ensemble_manager_mod -!> @ingroup coupler -!> @brief Routines for setting up and managing ensembles and ensemble pe lists. - -!> @addtogroup ensemble_manager_mod -!> @{ -module ensemble_manager_mod - - - use fms_mod, only : check_nml_error - use mpp_mod, only : mpp_npes, stdout, stdlog, mpp_error, FATAL - use mpp_mod, only : mpp_pe, mpp_declare_pelist - use mpp_mod, only : input_nml_file - use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix -#ifdef use_deprecated_io - use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix -#endif - - IMPLICIT NONE - - private - - integer, parameter :: MAX_ENSEMBLE_SIZE = 100 - - - integer, allocatable, dimension(:,:) :: ensemble_pelist - integer, allocatable, dimension(:,:) :: ensemble_pelist_ocean - integer, allocatable, dimension(:,:) :: ensemble_pelist_atmos - integer, allocatable, dimension(:,:) :: ensemble_pelist_land - integer, allocatable, dimension(:,:) :: ensemble_pelist_ice - integer, allocatable, dimension(:) :: ensemble_pelist_ocean_filter - integer, allocatable, dimension(:) :: ensemble_pelist_atmos_filter - integer, allocatable, dimension(:) :: ensemble_pelist_land_filter - integer, allocatable, dimension(:) :: ensemble_pelist_ice_filter - - integer :: ensemble_size = 1 - integer :: ensemble_id = 1 - integer :: pe, total_npes_pm=0,ocean_npes_pm=0,atmos_npes_pm=0 - integer :: land_npes_pm=0,ice_npes_pm=0 - - public :: ensemble_manager_init, get_ensemble_id, get_ensemble_size, get_ensemble_pelist - public :: ensemble_pelist_setup - public :: get_ensemble_filter_pelist -contains - -!> @brief Initializes @ref ensemble_manager_mod -!! -!> @throw FATAL, "ensemble_manager_mod: ensemble_nml variable ensemble_size must be a positive integer" -!! @throw FATAL, "ensemble_manager_mod: ensemble_nml variable ensemble_size should be no larger -!! than MAX_ENSEMBLE_SIZE, change ensemble_size or increase MAX_ENSEMBLE_SIZE" -!! @throw FATAL, "ensemble_size must be divis by npes" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 1st index < ensemble_size" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 2nd index < ocean_npes_pm" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 2nd index < atmos_npes_pm" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 2nd index < land_npes_pm" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 2nd index < ice_npes_pm" -!! @throw FATAL, "get_ensemble_pelist: unknown argument name=[name]" -!! @throw FATAL, "get_ensemble_pelist: size of pelist 2nd index < total_npes_pm" - subroutine ensemble_manager_init() - - - integer :: i, io_status, npes, ierr - - namelist /ensemble_nml/ ensemble_size - - read (input_nml_file, ensemble_nml, iostat=io_status) - ierr = check_nml_error(io_status, 'ensemble_nml') - - if(ensemble_size < 1) call mpp_error(FATAL, & - 'ensemble_manager_mod: ensemble_nml variable ensemble_size must be a positive integer') - if(ensemble_size > max_ensemble_size) call mpp_error(FATAL, & - 'ensemble_manager_mod: ensemble_nml variable ensemble_size should be no larger than MAX_ENSEMBLE_SIZE, '// & - 'change ensemble_size or increase MAX_ENSEMBLE_SIZE') - - pe = mpp_pe() - npes = mpp_npes() - if (npes < ensemble_size) then - call mpp_error(FATAL,'npes must be >= ensemble_size') - endif - total_npes_pm = npes/ensemble_size - if (mod(npes, total_npes_pm) /= 0) call mpp_error(FATAL,'ensemble_size must be divis by npes') - - call mpp_declare_pelist((/(i,i=0,npes-1)/),'_ens0') ! for ensemble driver - - end subroutine ensemble_manager_init - - !> @brief Getter function for ensemble_id - !! @return integer of ensemble id - function get_ensemble_id() - integer :: get_ensemble_id - get_ensemble_id = ensemble_id - end function get_ensemble_id - - !> @brief Returns ensemble size integer array - !! @return integer array of sizes - function get_ensemble_size() - - integer, dimension(6) :: get_ensemble_size - - get_ensemble_size(1) = ensemble_size - get_ensemble_size(2) = total_npes_pm - get_ensemble_size(3) = ocean_npes_pm - get_ensemble_size(4) = atmos_npes_pm - get_ensemble_size(5) = land_npes_pm - get_ensemble_size(6) = ice_npes_pm - - end function get_ensemble_size - - !> @brief Gets pe list for current ensemble or a given ensemble component. - subroutine get_ensemble_pelist(pelist, name) - - integer, intent(inout) :: pelist(:,:) !< Ensemble pelist - character(len=*), intent(in), optional :: name !< Component name. - - if (size(pelist,1) < ensemble_size) & - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 1st index < ensemble_size') - - if(present(name)) then - select case(name) - case('ocean') - if (size(pelist,2) < ocean_npes_pm)& - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < ocean_npes_pm') - pelist = 0 - pelist(1:ensemble_size,1:ocean_npes_pm) = & - ensemble_pelist_ocean(1:ensemble_size,1:ocean_npes_pm) - - case('atmos') - if (size(pelist,2) < atmos_npes_pm)& - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < atmos_npes_pm') - pelist = 0 - pelist(1:ensemble_size,1:atmos_npes_pm) = & - ensemble_pelist_atmos(1:ensemble_size,1:atmos_npes_pm) - - case('land') - if (size(pelist,2) < land_npes_pm)& - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < land_npes_pm') - pelist = 0 - pelist(1:ensemble_size,1:land_npes_pm) = & - ensemble_pelist_land(1:ensemble_size,1:land_npes_pm) - - case('ice') - if (size(pelist,2) < ice_npes_pm)& - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < ice_npes_pm') - pelist = 0 - pelist(1:ensemble_size,1:ice_npes_pm) = & - ensemble_pelist_ice(1:ensemble_size,1:ice_npes_pm) - - case default - call mpp_error(FATAL,'get_ensemble_pelist: unknown argument name='//name) - end select - else - if (size(pelist,2) < total_npes_pm)& - call mpp_error(FATAL,'get_ensemble_pelist: size of pelist 2nd index < total_npes_pm') - pelist = 0 - pelist(1:ensemble_size,1:total_npes_pm) = & - ensemble_pelist(1:ensemble_size,1:total_npes_pm) - endif - - return - end subroutine get_ensemble_pelist - -!> @brief Gets filter pelist for a given ensemble component. -!! -!! @throw FATAL, "get_ensemble_filter_pelist: size of pelist argument < ensemble_size * ocean_npes_pm" -!! @throw FATAL, "get_ensemble_filter_pelist: size of pelist argument < ensemble_size * atmos_npes_pm" -!! @throw FATAL, "get_ensemble_filter_pelist: size of pelist argument < ensemble_size * land_npes_pm" -!! @throw FATAL, "get_ensemble_filter_pelist: size of pelist argument < ensemble_size * ice_npes_pm" -!! @throw FATAL, "get_ensemble_filter_pelist: unknown argument name=[name]" - subroutine get_ensemble_filter_pelist(pelist, name) - - integer, intent(inout) :: pelist(:) !< Returned filter pe list - character(len=*), intent(in) :: name !< Ensemble component name - - select case(name) - case('ocean') - if (size(pelist) < ensemble_size * ocean_npes_pm)& - call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * ocean_npes_pm') - pelist = 0 - pelist(1:ensemble_size*ocean_npes_pm) = & - ensemble_pelist_ocean_filter(1:ensemble_size*ocean_npes_pm) - - case('atmos') - if (size(pelist) < ensemble_size * atmos_npes_pm)& - call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * atmos_npes_pm') - pelist = 0 - pelist(1:ensemble_size*atmos_npes_pm) = & - ensemble_pelist_atmos_filter(1:ensemble_size*atmos_npes_pm) - - case('land') - if (size(pelist) < ensemble_size * land_npes_pm)& - call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * land_npes_pm') - pelist = 0 - pelist(1:ensemble_size*land_npes_pm) = & - ensemble_pelist_land_filter(1:ensemble_size*land_npes_pm) - - case('ice') - if (size(pelist) < ensemble_size * ice_npes_pm)& - call mpp_error(FATAL,'get_ensemble_filter_pelist: size of pelist argument < ensemble_size * ice_npes_pm') - pelist = 0 - pelist(1:ensemble_size*ice_npes_pm) = & - ensemble_pelist_ice_filter(1:ensemble_size*ice_npes_pm) - - case default - call mpp_error(FATAL,'get_ensemble_filter_pelist: unknown argument name='//name) - end select - - - return - end subroutine get_ensemble_filter_pelist - -!nnz: I think the following block of code should be contained in a subroutine -! to consolidate and ensure the consistency of declaring the various pelists. -!> @brief Sets up pe list for an ensemble. -!! -!! @throw FATAL, "ensemble_manager_mod: land_npes > atmos_npes" -!! @throw FATAL, "ensemble_manager_mod: ice_npes > atmos_npes" - subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, & - Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist) - logical, intent(in) :: concurrent - integer, intent(in) :: atmos_npes, ocean_npes - integer, intent(in) :: land_npes, ice_npes - integer, dimension(:), intent(inout) :: Atm_pelist, Ocean_pelist - integer, dimension(:), intent(inout) :: Land_pelist, Ice_pelist - integer :: atmos_pe_start, atmos_pe_end, ocean_pe_start, ocean_pe_end - integer :: land_pe_start, land_pe_end, ice_pe_start, ice_pe_end - character(len=10) :: pelist_name, text - integer :: npes, n, m ,i - - npes = total_npes_pm - - ! make sure land_npes and ice_npes are not greater than atmos_npes - if(land_npes > atmos_npes) call mpp_error(FATAL, 'ensemble_manager_mod: land_npes > atmos_npes') - if(ice_npes > atmos_npes) call mpp_error(FATAL, 'ensemble_manager_mod: ice_npes > atmos_npes') - - allocate(ensemble_pelist(ensemble_size,total_npes_pm)) - allocate(ensemble_pelist_ocean(1:ensemble_size, 1:ocean_npes) ) - allocate(ensemble_pelist_atmos(1:ensemble_size, 1:atmos_npes) ) - allocate(ensemble_pelist_land (1:ensemble_size, 1:land_npes) ) - allocate(ensemble_pelist_ice (1:ensemble_size, 1:ice_npes) ) - - atmos_pe_start = 0 - ocean_pe_start = 0 - land_pe_start = 0 - ice_pe_start = 0 - if( concurrent .OR. atmos_npes+ocean_npes == npes )then - ocean_pe_start = ensemble_size*atmos_npes - endif - do n=1,ensemble_size - atmos_pe_end = atmos_pe_start + atmos_npes - 1 - ocean_pe_end = ocean_pe_start + ocean_npes - 1 - land_pe_end = land_pe_start + land_npes - 1 - ice_pe_end = ice_pe_start + ice_npes - 1 - ensemble_pelist_atmos(n, 1:atmos_npes) = (/(i,i=atmos_pe_start,atmos_pe_end)/) - ensemble_pelist_ocean(n, 1:ocean_npes) = (/(i,i=ocean_pe_start,ocean_pe_end)/) - ensemble_pelist_land (n, 1:land_npes) = (/(i,i=land_pe_start, land_pe_end)/) - ensemble_pelist_ice (n, 1:ice_npes) = (/(i,i=ice_pe_start, ice_pe_end)/) - ensemble_pelist(n, 1:atmos_npes) = ensemble_pelist_atmos(n, 1:atmos_npes) - if( concurrent .OR. atmos_npes+ocean_npes == npes ) & - ensemble_pelist(n, atmos_npes+1:npes) = ensemble_pelist_ocean(n, 1:ocean_npes) - if(ANY(ensemble_pelist(n,:) == pe)) ensemble_id = n - write(pelist_name,'(a,i2.2)') '_ens',n - call mpp_declare_pelist(ensemble_pelist(n,:), trim(pelist_name)) - atmos_pe_start = atmos_pe_end + 1 - ocean_pe_start = ocean_pe_end + 1 - land_pe_start = atmos_pe_start - ice_pe_start = atmos_pe_start - enddo - - Atm_pelist(:) = ensemble_pelist_atmos(ensemble_id,:) - Ocean_pelist(:) = ensemble_pelist_ocean(ensemble_id,:) - Land_pelist(:) = ensemble_pelist_land (ensemble_id,:) - Ice_pelist(:) = ensemble_pelist_ice (ensemble_id,:) - - ! write(pelist_name,'(a,i2.2)') '_ocn_ens',ensemble_id - ! call mpp_declare_pelist(Ocean%pelist , trim(pelist_name) ) - - ! write(pelist_name,'(a,i2.2)') '_atm_ens',ensemble_id - ! call mpp_declare_pelist(Atm%pelist , trim(pelist_name) ) - ! - !nnz: The above is sufficient for non-concurrent mode. - ! BUT - ! For atmosphere_init to work in ensemble, concurrent mode - ! the following Atm_pelist should be declared (per ensemble member) - ! instead of the above Atm%pelist! - ! - ! allocate( Atm_pelist(1:ensemble_size, 1:atmos_npes) ) - ! do n=1,ensemble_size - ! do i=1, atmos_npes - ! Atm_pelist(n, i) = ensemble_pelist(n, i) - ! enddo - ! write(pelist_name,'(a,i2.2)') '_atm_ens',n - ! call mpp_declare_pelist(Atm_pelist(n,:) , trim(pelist_name) ) - ! enddo - ! - ! The way I understand this with the help of Totalview is: - ! With mpp_declare_pelist(Atm%pelist) - ! When we are in fv_arrays_init when mp_init(comID) is called - ! comID is the same for the atmospheric PE's for both ensemble members - ! since peset(5)%id is the same (7) for those PE's, so the PE count is double what it should be inside - ! mp_init(). - ! It is also true that for Ocean PE's, peset(4)%id is the same (6) for Ocean PE's in both ensemble members - ! but for Ocean it is not a problem because Ocean is not trying to create new communicators - ! from this peset whereas ATM does (vis mp_init). - ! - ! Who sets peset(i)%id ? Can it be modified to assign different %id for the two subsets. - ! peset(i)%id = 0 for Ocean PE's on ATM pesets and for ATM PE's on Ocean pesets. - ! - ! With mpp_declare_pelist(Atm_pelist(n,:)) n=1,...,ensemble_size - ! we get separate pesets for each ATM ensemble member and each with a different %id and mp_init is cured. - ! - ! There is also a matter of precedence. If we have both calls - ! call mpp_declare_pelist(Atm%pelist , trim(pelist_name) ) - ! and - ! call mpp_declare_pelist(Atm_pelist(n,:) , trim(pelist_name) ) - ! then concurrent run fails because with call mpp_set_current_pelist( Atm%pelist ) - ! peset(i) is searched for i=1,2,... and the first pelist that matches argument, its peset is set as current. - ! - ! To be consistent with ATM and OCEAN we can do the following - ! (eventhough mpp_declare_pelist(Ocean%pelist) is adequate right now.) - - if( concurrent )then - do n=1,ensemble_size - write(pelist_name,'(a,i2.2)') 'atm_ens',n - call mpp_declare_pelist(ensemble_pelist_atmos(n,:) , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'ocn_ens',n - call mpp_declare_pelist(ensemble_pelist_ocean(n,:) , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'lnd_ens',n - call mpp_declare_pelist(ensemble_pelist_land(n,:) , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'ice_ens',n - call mpp_declare_pelist(ensemble_pelist_ice(n,:) , trim(pelist_name) ) - enddo - else - write(pelist_name,'(a,i2.2)') 'atm_ens',ensemble_id - call mpp_declare_pelist(Atm_pelist , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'ocn_ens',ensemble_id - call mpp_declare_pelist(Ocean_pelist , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'lnd_ens',ensemble_id - call mpp_declare_pelist(Land_pelist , trim(pelist_name) ) - write(pelist_name,'(a,i2.2)') 'ice_ens',ensemble_id - call mpp_declare_pelist(Ice_pelist , trim(pelist_name) ) - endif - - ocean_npes_pm = ocean_npes - atmos_npes_pm = atmos_npes - land_npes_pm = land_npes - ice_npes_pm = ice_npes - - !Declare pelist of all Ocean, Atmos, Land and Ice pes across all ensembles ( filters ) - allocate(ensemble_pelist_ocean_filter(ensemble_size * ocean_npes_pm)) - allocate(ensemble_pelist_atmos_filter(ensemble_size * atmos_npes_pm)) - allocate(ensemble_pelist_land_filter (ensemble_size * land_npes_pm)) - allocate(ensemble_pelist_ice_filter (ensemble_size * ice_npes_pm)) - do n=1,ensemble_size - do m=1,ocean_npes_pm - i=(n-1)*ocean_npes_pm + m - ensemble_pelist_ocean_filter(i) = ensemble_pelist_ocean(n,m) - enddo - do m=1,atmos_npes_pm - i=(n-1)*atmos_npes_pm + m - ensemble_pelist_atmos_filter(i) = ensemble_pelist_atmos(n,m) - enddo - do m=1,land_npes_pm - i=(n-1)*land_npes_pm + m - ensemble_pelist_land_filter(i) = ensemble_pelist_land(n,m) - enddo - do m=1,ice_npes_pm - i=(n-1)*ice_npes_pm + m - ensemble_pelist_ice_filter(i) = ensemble_pelist_ice(n,m) - enddo - enddo - - write(pelist_name,'(a)') 'ocn_filter' - call mpp_declare_pelist(ensemble_pelist_ocean_filter, trim(pelist_name) ) - - write(pelist_name,'(a)') 'atm_filter' - call mpp_declare_pelist(ensemble_pelist_atmos_filter, trim(pelist_name) ) - - write(pelist_name,'(a)') 'lnd_filter' - call mpp_declare_pelist(ensemble_pelist_land_filter, trim(pelist_name) ) - - write(pelist_name,'(a)') 'ice_filter' - call mpp_declare_pelist(ensemble_pelist_ice_filter, trim(pelist_name) ) - - ! - !Rename output files to identify the ensemble - !If ensemble_size=1 do not rename files so that the same coupler - !can be used for non-ensemble experiments - ! - if (ensemble_size > 1) then - write( text,'(a,i2.2)' ) 'ens_', ensemble_id - !Append ensemble_id to the restart filenames - - !< Both calls are needed for cases where both fms2io/fmsio are used - call fms2_io_set_filename_appendix(trim(text)) -#ifdef use_deprecated_io - call fms_io_set_filename_appendix(trim(text)) -#endif - endif - - end subroutine ensemble_pelist_setup - - -end module ensemble_manager_mod -!> @} -! close documentation grouping diff --git a/libFMS.F90 b/libFMS.F90 index 02b54df82a..42879958f5 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -143,14 +143,20 @@ module fms fms_coupler_type_set_data => coupler_type_set_data, & fms_coupler_type_copy_1d_2d => coupler_type_copy_1d_2d, & fms_coupler_type_copy_1d_3d => coupler_type_copy_1d_3d, & - FmsCoupler3dValues_type => coupler_3d_values_type, & - FmsCoupler3dField_type => coupler_3d_field_type, & + FmsCoupler3dValuesReals8_type => coupler_3d_real8_values_type, & + FmsCoupler3dFieldReals8_type => coupler_3d_real8_field_type, & + FmsCoupler2dValuesReals8_type => coupler_2d_real8_values_type, & + FmsCoupler2dFieldReals8_type => coupler_2d_real8_field_type, & + FmsCoupler1dValuesReals8_type => coupler_1d_real8_values_type, & + FmsCoupler1dFieldReals8_type => coupler_1d_real8_field_type, & + FmsCoupler3dValuesReals4_type => coupler_3d_real4_values_type, & + FmsCoupler3dFieldReals4_type => coupler_3d_real4_field_type, & + FmsCoupler2dValuesReals4_type => coupler_2d_real4_values_type, & + FmsCoupler2dFieldReals4_type => coupler_2d_real4_field_type, & + FmsCoupler1dValuesReals4_type => coupler_1d_real4_values_type, & + FmsCoupler1dFieldReals4_type => coupler_1d_real4_field_type, & FmsCoupler3dBC_type => coupler_3d_bc_type, & - FmsCoupler2dValues_type => coupler_2d_values_type, & - FmsCoupler2dField_type => coupler_2d_field_type, & FmsCoupler2dBC_type => coupler_2d_bc_type, & - FmsCoupler1dValues_type => coupler_1d_values_type, & - FmsCoupler1dField_type => coupler_1d_field_type, & FmsCoupler1dBC_type => coupler_1d_bc_type, & fms_coupler_ind_pcair => ind_pcair, & fms_coupler_ind_u10 => ind_u10, &