diff --git a/.codee-format b/.codee-format new file mode 100644 index 00000000..8ba68379 --- /dev/null +++ b/.codee-format @@ -0,0 +1,101 @@ +# DH* 20251208 - this initial .codee-format is +# identical to the NEPTUNE version except for +# Comments: ! IndentIfAlreadyIndented # Indent +# (in NEPTUNE, we use "Indent") + +# For a detailed description of all options, see: +# https://docs.codee.com/formatter/style-options + +AlignAmpersandToColumnLimit: false +AlignAssignmentOperators: true +AlignUseItems: + Kind: OneItemPerLine + FirstLineFit: FitIfPossible +BreakBeforeBinaryOperators: true +Casing: + Identifiers: Lowercase # Preserve + Keywords: Lowercase + LogicalConstants: Lowercase + LogicalOperators: Lowercase + RelationalOperators: Lowercase + UserDefinedOperators: Lowercase +ColumnLimit: 120 +CommentDirectivePrefixes: [] +DisabledDirectivePrefixes: [] +IndentSize: 2 +# DH* No exception for TypeContains, FunctionContains etc +# requested 2025/12/08 using the Codee Online Form +IndentExceptions: + ModuleContains: IndentBeforeAndAfter + Comments: IndentIfAlreadyIndented # Indent +FixedFormLabelAlignment: Right +ContinuationIndentSize: DoubleIndentSize +DoubleColonSeparator: AddAlways +EndOfLineNormalization: Unix # Autodetect +EndStatementFormat: EndStructureAndName +EndStatementSeparation: + EndAssociate: Separated + EndBlockConstruct: Separated + EndBlockData: Separated + EndCritical: Separated + EndTeam: Separated + EndDoLoop: Separated + EndEnum: Separated + EndEnumerationType: Separated + EndForall: Separated + EndFunction: Separated + EndIf: Separated + EndInterface: Separated + EndModule: Separated + EndModuleProcedure: Separated + EndProgram: Separated + EndSelect: Separated + EndSubmodule: Separated + EndSubroutine: Separated + EndType: Separated + EndWhere: Separated +EnsureNewlineAtEOF: true +ConsecutiveEmptyLines: + MaxToKeep: 1 + BetweenProcedures: 1 + RemoveAtStartOfFile: true + RemoveAtEndOfFile: true +KindKeywordPrefix: AddAlways +# DH* TODO FILL THIS LIST +MacroIdentifiers: [ + "__FILE__", + "__LINE__", + "_OPENMP", + ] +RelationalOperators: UseSymbols +# DH* Note. Filed ticket 276 with Codee to prevent +# spaces between dimensions in dimension specifications +# like 'real, dimension(:,:,:), allocatable :: x' +SpacesAroundOperators: + LeftParenthesisExpression: NoTrailing + LeftParenthesisGeneric: NoSpaces + LeftParenthesisKeyword: OnlyLeading + RightParenthesisExpression: NoLeading + RightParenthesisGeneric: NoLeading + RightParenthesisKeyword: OnlyTrailing # NoLeading + Assignment: Both + Association: Both + ControlFlowAssignment: Both + KeywordAssignment: NoSpaces + ParameterAssignment: NoSpaces + BinaryArithmetic: Both + Exponentiation: NoSpaces + DefinedBinary: Both + DefinedUnary: NoTrailing + Relational: Both + RelationalLegacy: Both + LogicalBinary: Both + LogicalNot: NoTrailing + UnaryPlusMinus: NoTrailing + Comma: OnlyTrailing + Concat: Both + DoubleColon: Both +RemoveConsecutiveWhitespace: true +RemoveSemicolons: true +RemoveTrailingWhitespace: true +SeparateMultipleInlineStatements: true diff --git a/run_codee_tmp.sh b/run_codee_tmp.sh new file mode 100755 index 00000000..a558887c --- /dev/null +++ b/run_codee_tmp.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +files=( + "src/ccpp_constituent_prop_mod.F90:free" + "src/ccpp_hashable.F90:free" + "src/ccpp_hash_table.F90:free" + "src/ccpp_scheme_utils.F90:free" + "src/ccpp_types.F90:free" +) + +for entry in "${files[@]}"; do + file="${entry%%:*}" + ext="${file##*.}" + fmt="${entry##*:}" + git checkout origin/develop -- $file + codee format --verbose --extensions=$ext --on-error force $file + echo "" + echo "-------------------------------------------------" +done diff --git a/src/ccpp_constituent_prop_mod.F90 b/src/ccpp_constituent_prop_mod.F90 index a08291b6..6e87eedc 100644 --- a/src/ccpp_constituent_prop_mod.F90 +++ b/src/ccpp_constituent_prop_mod.F90 @@ -1,2584 +1,2583 @@ module ccpp_constituent_prop_mod - ! ccpp_contituent_prop_mod contains types and procedures for storing - ! and retrieving constituent properties - - use ccpp_hashable, only: ccpp_hashable_t, ccpp_hashable_char_t - use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t - use ccpp_kinds, only: kind_phys - - implicit none - private - - !!XXgoldyXX: Implement "last_error" method so that functions do not - !! need to have output variables. - - ! Private module data - integer, parameter :: stdname_len = 256 - integer, parameter :: dimname_len = 32 - integer, parameter :: errmsg_len = 256 - integer, parameter :: dry_mixing_ratio = -2 - integer, parameter :: moist_mixing_ratio = -3 - integer, parameter :: wet_mixing_ratio = -4 - integer, parameter :: mass_mixing_ratio = -5 - integer, parameter :: volume_mixing_ratio = -6 - integer, parameter :: number_concentration = -7 - integer, public, parameter :: int_unassigned = -HUGE(1) - real(kind_phys), parameter :: kphys_unassigned = HUGE(1.0_kind_phys) + ! ccpp_contituent_prop_mod contains types and procedures for storing + ! and retrieving constituent properties + + use ccpp_hashable, only: ccpp_hashable_t, ccpp_hashable_char_t + use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t + use ccpp_kinds, only: kind_phys + + implicit none + private + + !!XXgoldyXX: Implement "last_error" method so that functions do not + !! need to have output variables. + + ! Private module data + integer, parameter :: stdname_len = 256 + integer, parameter :: dimname_len = 32 + integer, parameter :: errmsg_len = 256 + integer, parameter :: dry_mixing_ratio = -2 + integer, parameter :: moist_mixing_ratio = -3 + integer, parameter :: wet_mixing_ratio = -4 + integer, parameter :: mass_mixing_ratio = -5 + integer, parameter :: volume_mixing_ratio = -6 + integer, parameter :: number_concentration = -7 + integer, public, parameter :: int_unassigned = -huge(1) + real(kind=kind_phys), parameter :: kphys_unassigned = huge(1.0_kind_phys) !! \section arg_table_ccpp_constituent_properties_t !! \htmlinclude ccpp_constituent_properties_t.html !! - type, public, extends(ccpp_hashable_char_t) :: ccpp_constituent_properties_t - ! A ccpp_constituent_properties_t object holds relevant metadata - ! for a constituent species and provides interfaces to access that data. - character(len=:), private, allocatable :: var_std_name - character(len=:), private, allocatable :: var_long_name - character(len=:), private, allocatable :: var_units - character(len=:), private, allocatable :: vert_dim - integer, private :: const_ind = int_unassigned - logical, private :: advected = .false. - logical, private :: thermo_active = .false. - logical, private :: water_species = .false. - ! While the quantities below can be derived from the standard name, - ! this implementation avoids string searching in parameterizations - ! const_type distinguishes mass, volume, and number conc. mixing ratios - integer, private :: const_type = int_unassigned - ! const_water distinguishes dry, moist, and "wet" mixing ratios - integer, private :: const_water = int_unassigned - ! minimum_mr is the minimum allowed value (default zero) - real(kind_phys), private :: min_val = 0.0_kind_phys - ! molar_mass_val is the molar mass of the constituent (kg mol-1) - real(kind_phys), private :: molar_mass_val = kphys_unassigned - ! default_value is the default value that the constituent array will be - ! initialized to - real(kind_phys), private :: const_default_value = kphys_unassigned - contains - ! Required hashable method - procedure :: key => ccp_properties_get_key - ! Informational methods - procedure :: is_instantiated => ccp_is_instantiated - procedure :: standard_name => ccp_get_standard_name - procedure :: long_name => ccp_get_long_name - procedure :: units => ccp_get_units - procedure :: is_layer_var => ccp_is_layer_var - procedure :: is_interface_var => ccp_is_interface_var - procedure :: is_2d_var => ccp_is_2d_var - procedure :: vertical_dimension => ccp_get_vertical_dimension - procedure :: const_index => ccp_const_index - procedure :: is_advected => ccp_is_advected - procedure :: is_thermo_active => ccp_is_thermo_active - procedure :: is_water_species => ccp_is_water_species - procedure :: equivalent => ccp_is_equivalent - procedure :: is_mass_mixing_ratio => ccp_is_mass_mixing_ratio - procedure :: is_volume_mixing_ratio => ccp_is_volume_mixing_ratio - procedure :: is_number_concentration => ccp_is_number_concentration - procedure :: is_dry => ccp_is_dry - procedure :: is_moist => ccp_is_moist - procedure :: is_wet => ccp_is_wet - procedure :: minimum => ccp_min_val - procedure :: molar_mass => ccp_molar_mass - procedure :: default_value => ccp_default_value - procedure :: has_default => ccp_has_default - procedure :: is_match => ccp_is_match - ! Copy method (be sure to update this anytime fields are added) - procedure :: copyConstituent - generic :: assignment(=) => copyConstituent - ! Methods that change state (XXgoldyXX: make private?) - procedure :: instantiate => ccp_instantiate - procedure :: deallocate => ccp_deallocate - procedure :: set_const_index => ccp_set_const_index - procedure :: set_thermo_active => ccp_set_thermo_active - procedure :: set_water_species => ccp_set_water_species - procedure :: set_minimum => ccp_set_min_val - procedure :: set_molar_mass => ccp_set_molar_mass - end type ccpp_constituent_properties_t + type, public, extends(ccpp_hashable_char_t) :: ccpp_constituent_properties_t + ! A ccpp_constituent_properties_t object holds relevant metadata + ! for a constituent species and provides interfaces to access that data. + character(len=:), private, allocatable :: var_std_name + character(len=:), private, allocatable :: var_long_name + character(len=:), private, allocatable :: var_units + character(len=:), private, allocatable :: vert_dim + integer, private :: const_ind = int_unassigned + logical, private :: advected = .false. + logical, private :: thermo_active = .false. + logical, private :: water_species = .false. + ! While the quantities below can be derived from the standard name, + ! this implementation avoids string searching in parameterizations + ! const_type distinguishes mass, volume, and number conc. mixing ratios + integer, private :: const_type = int_unassigned + ! const_water distinguishes dry, moist, and "wet" mixing ratios + integer, private :: const_water = int_unassigned + ! minimum_mr is the minimum allowed value (default zero) + real(kind=kind_phys), private :: min_val = 0.0_kind_phys + ! molar_mass_val is the molar mass of the constituent (kg mol-1) + real(kind=kind_phys), private :: molar_mass_val = kphys_unassigned + ! default_value is the default value that the constituent array will be + ! initialized to + real(kind=kind_phys), private :: const_default_value = kphys_unassigned + contains + ! Required hashable method + procedure :: key => ccp_properties_get_key + ! Informational methods + procedure :: is_instantiated => ccp_is_instantiated + procedure :: standard_name => ccp_get_standard_name + procedure :: long_name => ccp_get_long_name + procedure :: units => ccp_get_units + procedure :: is_layer_var => ccp_is_layer_var + procedure :: is_interface_var => ccp_is_interface_var + procedure :: is_2d_var => ccp_is_2d_var + procedure :: vertical_dimension => ccp_get_vertical_dimension + procedure :: const_index => ccp_const_index + procedure :: is_advected => ccp_is_advected + procedure :: is_thermo_active => ccp_is_thermo_active + procedure :: is_water_species => ccp_is_water_species + procedure :: equivalent => ccp_is_equivalent + procedure :: is_mass_mixing_ratio => ccp_is_mass_mixing_ratio + procedure :: is_volume_mixing_ratio => ccp_is_volume_mixing_ratio + procedure :: is_number_concentration => ccp_is_number_concentration + procedure :: is_dry => ccp_is_dry + procedure :: is_moist => ccp_is_moist + procedure :: is_wet => ccp_is_wet + procedure :: minimum => ccp_min_val + procedure :: molar_mass => ccp_molar_mass + procedure :: default_value => ccp_default_value + procedure :: has_default => ccp_has_default + procedure :: is_match => ccp_is_match + ! Copy method (be sure to update this anytime fields are added) + procedure :: copyconstituent + generic :: assignment(=) => copyconstituent + ! Methods that change state (XXgoldyXX: make private?) + procedure :: instantiate => ccp_instantiate + procedure :: deallocate => ccp_deallocate + procedure :: set_const_index => ccp_set_const_index + procedure :: set_thermo_active => ccp_set_thermo_active + procedure :: set_water_species => ccp_set_water_species + procedure :: set_minimum => ccp_set_min_val + procedure :: set_molar_mass => ccp_set_molar_mass + end type ccpp_constituent_properties_t !! \section arg_table_ccpp_constituent_prop_ptr_t !! \htmlinclude ccpp_constituent_prop_ptr_t.html !! - type, public :: ccpp_constituent_prop_ptr_t - type(ccpp_constituent_properties_t), private, pointer :: prop => NULL() - contains - ! Informational methods - procedure :: standard_name => ccpt_get_standard_name - procedure :: long_name => ccpt_get_long_name - procedure :: units => ccpt_get_units - procedure :: is_layer_var => ccpt_is_layer_var - procedure :: is_interface_var => ccpt_is_interface_var - procedure :: is_2d_var => ccpt_is_2d_var - procedure :: vertical_dimension => ccpt_get_vertical_dimension - procedure :: const_index => ccpt_const_index - procedure :: is_advected => ccpt_is_advected - procedure :: is_thermo_active => ccpt_is_thermo_active - procedure :: is_water_species => ccpt_is_water_species - procedure :: is_mass_mixing_ratio => ccpt_is_mass_mixing_ratio - procedure :: is_volume_mixing_ratio => ccpt_is_volume_mixing_ratio - procedure :: is_number_concentration => ccpt_is_number_concentration - procedure :: is_dry => ccpt_is_dry - procedure :: is_moist => ccpt_is_moist - procedure :: is_wet => ccpt_is_wet - procedure :: minimum => ccpt_min_val - procedure :: molar_mass => ccpt_molar_mass - procedure :: default_value => ccpt_default_value - procedure :: has_default => ccpt_has_default - ! ccpt_set: Set the internal pointer - procedure :: set => ccpt_set - ! Methods that change state (XXgoldyXX: make private?) - procedure :: deallocate => ccpt_deallocate - procedure :: set_const_index => ccpt_set_const_index - procedure :: set_thermo_active => ccpt_set_thermo_active - procedure :: set_water_species => ccpt_set_water_species - procedure :: set_minimum => ccpt_set_min_val - procedure :: set_molar_mass => ccpt_set_molar_mass - end type ccpp_constituent_prop_ptr_t + type, public :: ccpp_constituent_prop_ptr_t + type(ccpp_constituent_properties_t), private, pointer :: prop => null() + contains + ! Informational methods + procedure :: standard_name => ccpt_get_standard_name + procedure :: long_name => ccpt_get_long_name + procedure :: units => ccpt_get_units + procedure :: is_layer_var => ccpt_is_layer_var + procedure :: is_interface_var => ccpt_is_interface_var + procedure :: is_2d_var => ccpt_is_2d_var + procedure :: vertical_dimension => ccpt_get_vertical_dimension + procedure :: const_index => ccpt_const_index + procedure :: is_advected => ccpt_is_advected + procedure :: is_thermo_active => ccpt_is_thermo_active + procedure :: is_water_species => ccpt_is_water_species + procedure :: is_mass_mixing_ratio => ccpt_is_mass_mixing_ratio + procedure :: is_volume_mixing_ratio => ccpt_is_volume_mixing_ratio + procedure :: is_number_concentration => ccpt_is_number_concentration + procedure :: is_dry => ccpt_is_dry + procedure :: is_moist => ccpt_is_moist + procedure :: is_wet => ccpt_is_wet + procedure :: minimum => ccpt_min_val + procedure :: molar_mass => ccpt_molar_mass + procedure :: default_value => ccpt_default_value + procedure :: has_default => ccpt_has_default + ! ccpt_set: Set the internal pointer + procedure :: set => ccpt_set + ! Methods that change state (XXgoldyXX: make private?) + procedure :: deallocate => ccpt_deallocate + procedure :: set_const_index => ccpt_set_const_index + procedure :: set_thermo_active => ccpt_set_thermo_active + procedure :: set_water_species => ccpt_set_water_species + procedure :: set_minimum => ccpt_set_min_val + procedure :: set_molar_mass => ccpt_set_molar_mass + end type ccpp_constituent_prop_ptr_t !! \section arg_table_ccpp_model_constituents_t !! \htmlinclude ccpp_model_constituents_t.html !! - type, public :: ccpp_model_constituents_t - ! A ccpp_model_constituents_t object holds all the metadata and field - ! data for a model run's constituents along with data and methods - ! to initialize and access the data. - !!XXgoldyXX: To do: allow accessor functions as CCPP local variable - !! names so that members can be private. - integer :: num_layer_vars = 0 - integer :: num_advected_vars = 0 - integer, private :: num_layers = 0 - type(ccpp_hash_table_t), private :: hash_table - logical, private :: table_locked = .false. - logical, private :: data_locked = .false. - ! These fields are public to allow for efficient (i.e., no copying) - ! usage even though it breaks object independence - real(kind_phys), allocatable :: vars_layer(:,:,:) - real(kind_phys), allocatable :: vars_layer_tend(:,:,:) - real(kind_phys), allocatable :: vars_minvalue(:) - ! An array containing all the constituent metadata - ! Each element contains a pointer to a constituent from the hash table - type(ccpp_constituent_prop_ptr_t), allocatable :: const_metadata(:) - contains - ! Return .true. if a constituent matches pattern - procedure, private :: is_match => ccp_model_const_is_match - ! Return a constituent from the hash table - procedure, private :: find_const => ccp_model_const_find_const - ! Are both the properties table and data array locked (i.e., ready to be used)? - procedure :: locked => ccp_model_const_locked - ! Is the properties table locked (i.e., ready to be used)? - procedure :: const_props_locked => ccp_model_const_props_locked - ! Is the data array locked (i.e., ready to be used)? - procedure :: const_data_locked => ccp_model_const_data_locked - ! Is it okay to add new metadata fields? - procedure :: okay_to_add => ccp_model_const_okay_to_add - ! Add a constituent's metadata to the master hash table - procedure :: new_field => ccp_model_const_add_metadata - ! Initialize hash table - procedure :: initialize_table => ccp_model_const_initialize - ! Freeze hash table and set constituents properties - procedure :: lock_table => ccp_model_const_table_lock - ! Freeze and initialize constituent field arrays - procedure :: lock_data => ccp_model_const_data_lock - ! Empty (reset) the entire object - procedure :: reset => ccp_model_const_reset - ! Query number of constituents matching pattern - procedure :: num_constituents => ccp_model_const_num_match - ! Return index of constituent matching standard name - procedure :: const_index => ccp_model_const_index - ! Return metadata matching standard name - procedure :: field_metadata => ccp_model_const_metadata - ! Gather constituent fields matching pattern - procedure :: copy_in => ccp_model_const_copy_in_3d - ! Update constituent fields matching pattern - procedure :: copy_out => ccp_model_const_copy_out_3d - ! Return pointer to constituent array (for use by host model) - procedure :: field_data_ptr => ccp_field_data_ptr - ! Return pointer to advected constituent array (for use by host model) - procedure :: advected_constituents_ptr => ccp_advected_data_ptr - ! Return pointer to constituent properties array (for use by host model) - procedure :: constituent_props_ptr => ccp_constituent_props_ptr - end type ccpp_model_constituents_t - - ! Private interfaces - private to_str - private initialize_errvars - private append_errvars - private handle_allocate_error - private check_var_bounds - -CONTAINS - - !######################################################################## - ! - ! CCPP_CONSTITUENT_PROPERTIES_T (constituent metadata) methods - ! - !######################################################################## - - subroutine copyConstituent(outConst, inConst) - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: outConst - type(ccpp_constituent_properties_t), intent(in) :: inConst - - outConst%var_std_name = inConst%var_std_name - outConst%var_long_name = inConst%var_long_name - outConst%vert_dim = inConst%vert_dim - outConst%const_ind = inConst%const_ind - outConst%advected = inConst%advected - outConst%const_type = inConst%const_type - outConst%const_water = inConst%const_water - outConst%min_val = inConst%min_val - outConst%const_default_value = inConst%const_default_value - outConst%molar_mass_val = inConst%molar_mass_val - outConst%thermo_active = inConst%thermo_active - outConst%water_species = inConst%water_species - outConst%var_units = inConst%var_units - outConst%const_water = inConst%const_water - end subroutine copyConstituent - - !####################################################################### - - character(len=10) function to_str(val) - ! return default integer as a left justified string - - ! Dummy argument - integer, intent(in) :: val - - write(to_str,'(i0)') val - - end function to_str - - !####################################################################### - - subroutine initialize_errvars(errcode, errmsg) - ! Initialize error variables, if present - - ! Dummy arguments - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (present(errcode)) then - errcode = 0 - end if - if (present(errmsg)) then - errmsg = '' - end if - end subroutine initialize_errvars - - !####################################################################### - - subroutine append_errvars(errcode_val, errmsg_val, subname, errcode, errmsg, caller) - ! Append to error variables, if present - - ! Dummy arguments - integer, intent(in) :: errcode_val - character(len=*), intent(in) :: errmsg_val - character(len=*), intent(in) :: subname - integer, optional, intent(inout) :: errcode - character(len=*), optional, intent(inout) :: errmsg - character(len=*), optional, intent(in) :: caller - ! Local variable - integer :: emsg_len - - if (present(errcode)) then - errcode = errcode + errcode_val - end if - if (present(errmsg)) then - emsg_len = len_trim(errmsg) - if (emsg_len > 0) then - errmsg(emsg_len+1:) = '; ' - end if - emsg_len = len_trim(errmsg) - if (present(caller)) then - errmsg(emsg_len+1:) = trim(caller)//" "//trim(errmsg_val) - else - errmsg(emsg_len+1:) = trim(subname)//" "//trim(errmsg_val) - end if - end if - end subroutine append_errvars - - !####################################################################### - - subroutine handle_allocate_error(astat, fieldname, subname, errcode, errmsg) - ! Generate an error message if indicates an allocation failure - - ! Dummy arguments - integer, intent(in) :: astat - character(len=*), intent(in) :: fieldname - character(len=*), intent(in) :: subname - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - call initialize_errvars(errcode, errmsg) - if (astat /= 0) then - call append_errvars(astat, "Error allocating ccpp_constituent_properties_t object component " // & - trim(fieldname) // ", error code = " // to_str(astat), subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine handle_allocate_error - - !####################################################################### - - subroutine check_var_bounds(var, var_bound, varname, subname, errcode, errmsg) - ! Generate an error message if indicates an allocation failure - - ! Dummy arguments - integer, intent(in) :: var - integer, intent(in) :: var_bound - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: subname - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - call initialize_errvars(errcode, errmsg) - if (var > var_bound) then - call append_errvars(1, trim(varname)//" exceeds its upper bound, " // & - to_str(var_bound), subname, errcode=errcode, errmsg=errmsg) - end if - end subroutine check_var_bounds - - !####################################################################### - - function ccp_properties_get_key(hashable) - ! Return the constituent properties class key (var_std_name) - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: hashable - character(len=:), allocatable :: ccp_properties_get_key - - ccp_properties_get_key = hashable%var_std_name - - end function ccp_properties_get_key - - !####################################################################### - - logical function ccp_is_instantiated(this, errcode, errmsg) - ! Return .true. iff is instantiated - ! If is *not* instantiated and and/or is present, - ! fill these fields with an error status - ! If *is* instantiated and and/or is present, - ! clear these fields. - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), parameter :: subname = 'ccp_is_instantiated' - - ccp_is_instantiated = allocated(this%var_std_name) - call initialize_errvars(errcode, errmsg) - if (.not. ccp_is_instantiated) then - call append_errvars(1, "ccpp_constituent_properties_t object is not initialized", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end function ccp_is_instantiated - - !####################################################################### - - subroutine ccp_instantiate(this, std_name, long_name, units, vertical_dim, & - advected, default_value, min_value, molar_mass, water_species, & - mixing_ratio_type, errcode, errmsg) - ! Initialize all fields in - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - character(len=*), intent(in) :: std_name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: units - character(len=*), intent(in) :: vertical_dim - logical, optional, intent(in) :: advected - real(kind_phys), optional, intent(in) :: default_value - real(kind_phys), optional, intent(in) :: min_value - real(kind_phys), optional, intent(in) :: molar_mass - logical, optional, intent(in) :: water_species - character(len=*), optional, intent(in) :: mixing_ratio_type - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - - if (this%is_instantiated()) then - errcode = 1 - write(errmsg, *) 'ccpp_constituent_properties_t object, ', & - trim(std_name), ', is already initialized as ', this%var_std_name + type, public :: ccpp_model_constituents_t + ! A ccpp_model_constituents_t object holds all the metadata and field + ! data for a model run's constituents along with data and methods + ! to initialize and access the data. + !!XXgoldyXX: To do: allow accessor functions as CCPP local variable + !! names so that members can be private. + integer :: num_layer_vars = 0 + integer :: num_advected_vars = 0 + integer, private :: num_layers = 0 + type(ccpp_hash_table_t), private :: hash_table + logical, private :: table_locked = .false. + logical, private :: data_locked = .false. + ! These fields are public to allow for efficient (i.e., no copying) + ! usage even though it breaks object independence + real(kind=kind_phys), allocatable :: vars_layer(:, :, :) + real(kind=kind_phys), allocatable :: vars_layer_tend(:, :, :) + real(kind=kind_phys), allocatable :: vars_minvalue(:) + ! An array containing all the constituent metadata + ! Each element contains a pointer to a constituent from the hash table + type(ccpp_constituent_prop_ptr_t), allocatable :: const_metadata(:) + contains + ! Return .true. if a constituent matches pattern + procedure, private :: is_match => ccp_model_const_is_match + ! Return a constituent from the hash table + procedure, private :: find_const => ccp_model_const_find_const + ! Are both the properties table and data array locked (i.e., ready to be used)? + procedure :: locked => ccp_model_const_locked + ! Is the properties table locked (i.e., ready to be used)? + procedure :: const_props_locked => ccp_model_const_props_locked + ! Is the data array locked (i.e., ready to be used)? + procedure :: const_data_locked => ccp_model_const_data_locked + ! Is it okay to add new metadata fields? + procedure :: okay_to_add => ccp_model_const_okay_to_add + ! Add a constituent's metadata to the master hash table + procedure :: new_field => ccp_model_const_add_metadata + ! Initialize hash table + procedure :: initialize_table => ccp_model_const_initialize + ! Freeze hash table and set constituents properties + procedure :: lock_table => ccp_model_const_table_lock + ! Freeze and initialize constituent field arrays + procedure :: lock_data => ccp_model_const_data_lock + ! Empty (reset) the entire object + procedure :: reset => ccp_model_const_reset + ! Query number of constituents matching pattern + procedure :: num_constituents => ccp_model_const_num_match + ! Return index of constituent matching standard name + procedure :: const_index => ccp_model_const_index + ! Return metadata matching standard name + procedure :: field_metadata => ccp_model_const_metadata + ! Gather constituent fields matching pattern + procedure :: copy_in => ccp_model_const_copy_in_3d + ! Update constituent fields matching pattern + procedure :: copy_out => ccp_model_const_copy_out_3d + ! Return pointer to constituent array (for use by host model) + procedure :: field_data_ptr => ccp_field_data_ptr + ! Return pointer to advected constituent array (for use by host model) + procedure :: advected_constituents_ptr => ccp_advected_data_ptr + ! Return pointer to constituent properties array (for use by host model) + procedure :: constituent_props_ptr => ccp_constituent_props_ptr + end type ccpp_model_constituents_t + + ! Private interfaces + private to_str + private initialize_errvars + private append_errvars + private handle_allocate_error + private check_var_bounds + +contains + + !######################################################################## + ! + ! CCPP_CONSTITUENT_PROPERTIES_T (constituent metadata) methods + ! + !######################################################################## + + subroutine copyconstituent(outconst, inconst) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: outconst + type(ccpp_constituent_properties_t), intent(in) :: inconst + + outconst%var_std_name = inconst%var_std_name + outconst%var_long_name = inconst%var_long_name + outconst%vert_dim = inconst%vert_dim + outconst%const_ind = inconst%const_ind + outconst%advected = inconst%advected + outconst%const_type = inconst%const_type + outconst%const_water = inconst%const_water + outconst%min_val = inconst%min_val + outconst%const_default_value = inconst%const_default_value + outconst%molar_mass_val = inconst%molar_mass_val + outconst%thermo_active = inconst%thermo_active + outconst%water_species = inconst%water_species + outconst%var_units = inconst%var_units + outconst%const_water = inconst%const_water + end subroutine copyconstituent + + !####################################################################### + + character(len=10) function to_str(val) + ! return default integer as a left justified string + + ! Dummy argument + integer, intent(in) :: val + + write(to_str, '(i0)') val + + end function to_str + + !####################################################################### + + subroutine initialize_errvars(errcode, errmsg) + ! Initialize error variables, if present + + ! Dummy arguments + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + if (present(errcode)) then + errcode = 0 + end if + if (present(errmsg)) then + errmsg = '' + end if + end subroutine initialize_errvars + + !####################################################################### + + subroutine append_errvars(errcode_val, errmsg_val, subname, errcode, errmsg, caller) + ! Append to error variables, if present + + ! Dummy arguments + integer, intent(in) :: errcode_val + character(len=*), intent(in) :: errmsg_val + character(len=*), intent(in) :: subname + integer, optional, intent(inout) :: errcode + character(len=*), optional, intent(inout) :: errmsg + character(len=*), optional, intent(in) :: caller + ! Local variable + integer :: emsg_len + + if (present(errcode)) then + errcode = errcode + errcode_val + end if + if (present(errmsg)) then + emsg_len = len_trim(errmsg) + if (emsg_len > 0) then + errmsg(emsg_len + 1:) = '; ' + end if + emsg_len = len_trim(errmsg) + if (present(caller)) then + errmsg(emsg_len + 1:) = trim(caller) // " " // trim(errmsg_val) else - errcode = 0 - errmsg = '' - this%var_std_name = trim(std_name) - end if - if (errcode == 0) then - this%var_long_name = trim(long_name) - this%var_units = trim(units) - this%vert_dim = trim(vertical_dim) - if (present(advected)) then - this%advected = advected - else - this%advected = .false. - end if - if (present(default_value)) then - this%const_default_value = default_value - end if - if (present(min_value)) then - this%min_val = min_value - end if - if (present(molar_mass)) then - this%molar_mass_val = molar_mass - end if - if (present(water_species)) then - this%water_species = water_species - end if - end if - if (errcode == 0) then - if (index(this%var_std_name, "volume_mixing_ratio") > 0) then - this%const_type = volume_mixing_ratio - else if (index(this%var_std_name, "number_concentration") > 0) then - this%const_type = number_concentration - else - this%const_type = mass_mixing_ratio - end if - end if - if (errcode == 0) then - ! Determine if this mixing ratio is dry, moist, or "wet". - ! If a type was provided, use that (if it's valid) - if (present(mixing_ratio_type)) then - if (trim(mixing_ratio_type) == 'wet') then - this%const_water = wet_mixing_ratio - else if (trim(mixing_ratio_type) == 'moist') then - this%const_water = moist_mixing_ratio - else if (trim(mixing_ratio_type) == 'dry') then - this%const_water = dry_mixing_ratio - else - errcode = 1 - write(errmsg, *) 'ccp_instantiate: invalid mixing ratio type. ', & - 'Must be one of: "wet", "moist", or "dry". Got: "', & - trim(mixing_ratio_type), '"' - end if - else - ! Otherwise, parse it from the standard name - if (index(this%var_std_name, "wrt_moist_air_and_condensed_water") > 0) then - this%const_water = wet_mixing_ratio - else if (index(this%var_std_name, "wrt_moist_air") > 0) then - this%const_water = moist_mixing_ratio - else - this%const_water = dry_mixing_ratio - end if - end if - end if - if (errcode /= 0) then - call this%deallocate() - end if - end subroutine ccp_instantiate - - !####################################################################### - - subroutine ccp_deallocate(this) - ! Deallocate memory associated with this constituent property object - - ! Dummy argument - class(ccpp_constituent_properties_t), intent(inout) :: this - - if (allocated(this%var_std_name)) then - deallocate(this%var_std_name) - end if - if (allocated(this%var_long_name)) then - deallocate(this%var_long_name) - end if - if (allocated(this%vert_dim)) then - deallocate(this%vert_dim) - end if - this%const_ind = int_unassigned - this%advected = .false. - this%const_type = int_unassigned - this%const_water = int_unassigned - this%const_default_value = kphys_unassigned - - end subroutine ccp_deallocate - - !####################################################################### - - subroutine ccp_get_standard_name(this, std_name, errcode, errmsg) - ! Return this constituent's standard name - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - character(len=*), intent(out) :: std_name - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - std_name = this%var_std_name + errmsg(emsg_len + 1:) = trim(subname) // " " // trim(errmsg_val) + end if + end if + end subroutine append_errvars + + !####################################################################### + + subroutine handle_allocate_error(astat, fieldname, subname, errcode, errmsg) + ! Generate an error message if indicates an allocation failure + + ! Dummy arguments + integer, intent(in) :: astat + character(len=*), intent(in) :: fieldname + character(len=*), intent(in) :: subname + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + call initialize_errvars(errcode, errmsg) + if (astat /= 0) then + call append_errvars(astat, "Error allocating ccpp_constituent_properties_t object component " // & + trim(fieldname) // ", error code = " // to_str(astat), subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine handle_allocate_error + + !####################################################################### + + subroutine check_var_bounds(var, var_bound, varname, subname, errcode, errmsg) + ! Generate an error message if indicates an allocation failure + + ! Dummy arguments + integer, intent(in) :: var + integer, intent(in) :: var_bound + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: subname + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + call initialize_errvars(errcode, errmsg) + if (var > var_bound) then + call append_errvars(1, trim(varname) // " exceeds its upper bound, " // & + to_str(var_bound), subname, errcode=errcode, errmsg=errmsg) + end if + end subroutine check_var_bounds + + !####################################################################### + + function ccp_properties_get_key(hashable) + ! Return the constituent properties class key (var_std_name) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: hashable + character(len=:), allocatable :: ccp_properties_get_key + + ccp_properties_get_key = hashable%var_std_name + + end function ccp_properties_get_key + + !####################################################################### + + logical function ccp_is_instantiated(this, errcode, errmsg) + ! Return .true. iff is instantiated + ! If is *not* instantiated and and/or is present, + ! fill these fields with an error status + ! If *is* instantiated and and/or is present, + ! clear these fields. + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), parameter :: subname = 'ccp_is_instantiated' + + ccp_is_instantiated = allocated(this%var_std_name) + call initialize_errvars(errcode, errmsg) + if (.not.ccp_is_instantiated) then + call append_errvars(1, "ccpp_constituent_properties_t object is not initialized", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end function ccp_is_instantiated + + !####################################################################### + + subroutine ccp_instantiate(this, std_name, long_name, units, vertical_dim, & + advected, default_value, min_value, molar_mass, water_species, & + mixing_ratio_type, errcode, errmsg) + ! Initialize all fields in + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + character(len=*), intent(in) :: std_name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + character(len=*), intent(in) :: vertical_dim + logical, optional, intent(in) :: advected + real(kind=kind_phys), optional, intent(in) :: default_value + real(kind=kind_phys), optional, intent(in) :: min_value + real(kind=kind_phys), optional, intent(in) :: molar_mass + logical, optional, intent(in) :: water_species + character(len=*), optional, intent(in) :: mixing_ratio_type + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated()) then + errcode = 1 + write(errmsg, *) 'ccpp_constituent_properties_t object, ', & + trim(std_name), ', is already initialized as ', this%var_std_name + else + errcode = 0 + errmsg = '' + this%var_std_name = trim(std_name) + end if + if (errcode == 0) then + this%var_long_name = trim(long_name) + this%var_units = trim(units) + this%vert_dim = trim(vertical_dim) + if (present(advected)) then + this%advected = advected else - std_name = '' + this%advected = .false. end if - - end subroutine ccp_get_standard_name - - !####################################################################### - - subroutine ccp_get_long_name(this, long_name, errcode, errmsg) - ! Return this constituent's long name (description) - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - character(len=*), intent(out) :: long_name - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - long_name = this%var_long_name - else - long_name = '' + if (present(default_value)) then + this%const_default_value = default_value end if - - end subroutine ccp_get_long_name - - !####################################################################### - - subroutine ccp_get_units(this, units, errcode, errmsg) - ! Return this constituent's units - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - character(len=*), intent(out) :: units - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - units = this%var_units - else - units = '' + if (present(min_value)) then + this%min_val = min_value end if - - end subroutine ccp_get_units - - !####################################################################### - - subroutine ccp_get_vertical_dimension(this, vert_dim, errcode, errmsg) - ! Return the standard name of this constituent's vertical dimension - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - character(len=*), intent(out) :: vert_dim - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - vert_dim = this%vert_dim - else - vert_dim = '' + if (present(molar_mass)) then + this%molar_mass_val = molar_mass end if - - end subroutine ccp_get_vertical_dimension - - !####################################################################### - - logical function ccp_is_layer_var(this) result(is_layer) - ! Return .true. iff this constituent has a layer vertical dimension - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - ! Local variable - character(len=dimname_len) :: dimname - - call this%vertical_dimension(dimname) - is_layer = trim(dimname) == 'vertical_layer_dimension' - - end function ccp_is_layer_var - - !####################################################################### - - logical function ccp_is_interface_var(this) result(is_interface) - ! Return .true. iff this constituent has a interface vertical dimension - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - ! Local variable - character(len=dimname_len) :: dimname - - call this%vertical_dimension(dimname) - is_interface = trim(dimname) == 'vertical_interface_dimension' - - end function ccp_is_interface_var - - !####################################################################### - - logical function ccp_is_2d_var(this) result(is_2d) - ! Return .true. iff this constituent has a 2d vertical dimension - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - ! Local variable - character(len=dimname_len) :: dimname - - call this%vertical_dimension(dimname) - is_2d = len_trim(dimname) == 0 - - end function ccp_is_2d_var - - !####################################################################### - - integer function ccp_const_index(this, errcode, errmsg) - ! Return this constituent's array index (or -1 of not assigned) - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - ccp_const_index = this%const_ind + if (present(water_species)) then + this%water_species = water_species + end if + end if + if (errcode == 0) then + if (index(this%var_std_name, "volume_mixing_ratio") > 0) then + this%const_type = volume_mixing_ratio + else if (index(this%var_std_name, "number_concentration") > 0) then + this%const_type = number_concentration else - ccp_const_index = int_unassigned - end if - - end function ccp_const_index - - !####################################################################### - - subroutine ccp_set_const_index(this, index, errcode, errmsg) - ! Set this constituent's index in the master constituent array - ! It is an error to try to set an index if it is already set - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - integer, intent(in) :: index - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), parameter :: subname = 'ccp_set_const_index' - - if (this%is_instantiated(errcode, errmsg)) then - if (this%const_ind == int_unassigned) then - this%const_ind = index - else - call append_errvars(1, "ccpp_constituent_properties_t const index " // & - "is already set", subname, errcode=errcode, errmsg=errmsg) - end if - end if - - end subroutine ccp_set_const_index - - !####################################################################### - - subroutine ccp_set_thermo_active(this, thermo_flag, errcode, errmsg) - ! Set whether this constituent is thermodynamically active, which - ! means that certain physics schemes will use this constitutent - ! when calculating thermodynamic quantities (e.g. enthalpy). - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - logical, intent(in) :: thermo_flag - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - !Set thermodynamically active flag for this constituent: - if (this%is_instantiated(errcode, errmsg)) then - this%thermo_active = thermo_flag - end if - - end subroutine ccp_set_thermo_active - - !####################################################################### - - subroutine ccp_set_water_species(this, water_flag, errcode, errmsg) - ! Set whether this constituent is a water species, which means - ! that this constituent represents a particular phase or type - ! of water in the atmosphere. - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - logical, intent(in) :: water_flag - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg + this%const_type = mass_mixing_ratio + end if + end if + if (errcode == 0) then + ! Determine if this mixing ratio is dry, moist, or "wet". + ! If a type was provided, use that (if it's valid) + if (present(mixing_ratio_type)) then + if (trim(mixing_ratio_type) == 'wet') then + this%const_water = wet_mixing_ratio + else if (trim(mixing_ratio_type) == 'moist') then + this%const_water = moist_mixing_ratio + else if (trim(mixing_ratio_type) == 'dry') then + this%const_water = dry_mixing_ratio + else + errcode = 1 + write(errmsg, *) 'ccp_instantiate: invalid mixing ratio type. ', & + 'Must be one of: "wet", "moist", or "dry". Got: "', & + trim(mixing_ratio_type), '"' + end if + else + ! Otherwise, parse it from the standard name + if (index(this%var_std_name, "wrt_moist_air_and_condensed_water") > 0) then + this%const_water = wet_mixing_ratio + else if (index(this%var_std_name, "wrt_moist_air") > 0) then + this%const_water = moist_mixing_ratio + else + this%const_water = dry_mixing_ratio + end if + end if + end if + if (errcode /= 0) then + call this%deallocate() + end if + end subroutine ccp_instantiate + + !####################################################################### + + subroutine ccp_deallocate(this) + ! Deallocate memory associated with this constituent property object + + ! Dummy argument + class(ccpp_constituent_properties_t), intent(inout) :: this + + if (allocated(this%var_std_name)) then + deallocate(this%var_std_name) + end if + if (allocated(this%var_long_name)) then + deallocate(this%var_long_name) + end if + if (allocated(this%vert_dim)) then + deallocate(this%vert_dim) + end if + this%const_ind = int_unassigned + this%advected = .false. + this%const_type = int_unassigned + this%const_water = int_unassigned + this%const_default_value = kphys_unassigned - !Set water species flag for this constituent: - if (this%is_instantiated(errcode, errmsg)) then - this%water_species = water_flag - end if + end subroutine ccp_deallocate + + !####################################################################### - end subroutine ccp_set_water_species + subroutine ccp_get_standard_name(this, std_name, errcode, errmsg) + ! Return this constituent's standard name - !####################################################################### + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + character(len=*), intent(out) :: std_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - subroutine ccp_is_thermo_active(this, val_out, errcode, errmsg) + if (this%is_instantiated(errcode, errmsg)) then + std_name = this%var_std_name + else + std_name = '' + end if - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg + end subroutine ccp_get_standard_name - !If instantiated then check if constituent is - !thermodynamically active, otherwise return false: - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%thermo_active - else - val_out = .false. - end if - end subroutine ccp_is_thermo_active + !####################################################################### - !####################################################################### + subroutine ccp_get_long_name(this, long_name, errcode, errmsg) + ! Return this constituent's long name (description) - subroutine ccp_is_water_species(this, val_out, errcode, errmsg) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + character(len=*), intent(out) :: long_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg + if (this%is_instantiated(errcode, errmsg)) then + long_name = this%var_long_name + else + long_name = '' + end if - !If instantiated then check if constituent is - !a water species, otherwise return false: - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%water_species - else - val_out = .false. - end if - end subroutine ccp_is_water_species + end subroutine ccp_get_long_name - !####################################################################### + !####################################################################### - subroutine ccp_is_advected(this, val_out, errcode, errmsg) + subroutine ccp_get_units(this, units, errcode, errmsg) + ! Return this constituent's units - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + character(len=*), intent(out) :: units + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%advected - else - val_out = .false. - end if - end subroutine ccp_is_advected - - !####################################################################### - - subroutine ccp_is_equivalent(this, oconst, equiv, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - type(ccpp_constituent_properties_t), intent(in) :: oconst - logical, intent(out) :: equiv - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg) .and. & - oconst%is_instantiated(errcode, errmsg)) then - equiv = (trim(this%var_std_name) == trim(oconst%var_std_name)) .and. & - (trim(this%var_long_name) == trim(oconst%var_long_name)) .and. & - (trim(this%vert_dim) == trim(oconst%vert_dim)) .and. & - (trim(this%var_units) == trim(oconst%var_units)) .and. & - (this%advected .eqv. oconst%advected) .and. & - (this%const_default_value == oconst%const_default_value) .and. & - (this%min_val == oconst%min_val) .and. & - (this%molar_mass_val == oconst%molar_mass_val) .and. & - (this%thermo_active .eqv. oconst%thermo_active) .and. & - (this%const_water == oconst%const_water) .and. & - (this%water_species .eqv. oconst%water_species) - else - equiv = .false. - end if + if (this%is_instantiated(errcode, errmsg)) then + units = this%var_units + else + units = '' + end if - end subroutine ccp_is_equivalent + end subroutine ccp_get_units - !######################################################################## + !####################################################################### - subroutine ccp_is_mass_mixing_ratio(this, val_out, errcode, errmsg) + subroutine ccp_get_vertical_dimension(this, vert_dim, errcode, errmsg) + ! Return the standard name of this constituent's vertical dimension - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + character(len=*), intent(out) :: vert_dim + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_type == mass_mixing_ratio - else - val_out = .false. - end if - end subroutine ccp_is_mass_mixing_ratio + if (this%is_instantiated(errcode, errmsg)) then + vert_dim = this%vert_dim + else + vert_dim = '' + end if - !######################################################################## + end subroutine ccp_get_vertical_dimension - subroutine ccp_is_volume_mixing_ratio(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_type == volume_mixing_ratio - else - val_out = .false. - end if - end subroutine ccp_is_volume_mixing_ratio + !####################################################################### - !######################################################################## + logical function ccp_is_layer_var(this) result(is_layer) + ! Return .true. iff this constituent has a layer vertical dimension - subroutine ccp_is_number_concentration(this, val_out, errcode, errmsg) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + ! Local variable + character(len=dimname_len) :: dimname - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + call this%vertical_dimension(dimname) + is_layer = trim(dimname) == 'vertical_layer_dimension' - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_type == number_concentration - else - val_out = .false. - end if - end subroutine ccp_is_number_concentration + end function ccp_is_layer_var - !######################################################################## + !####################################################################### - subroutine ccp_is_dry(this, val_out, errcode, errmsg) + logical function ccp_is_interface_var(this) result(is_interface) + ! Return .true. iff this constituent has a interface vertical dimension - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + ! Local variable + character(len=dimname_len) :: dimname - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_water == dry_mixing_ratio - else - val_out = .false. - end if + call this%vertical_dimension(dimname) + is_interface = trim(dimname) == 'vertical_interface_dimension' - end subroutine ccp_is_dry + end function ccp_is_interface_var - !######################################################################## + !####################################################################### - subroutine ccp_is_moist(this, val_out, errcode, errmsg) + logical function ccp_is_2d_var(this) result(is_2d) + ! Return .true. iff this constituent has a 2d vertical dimension - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + ! Local variable + character(len=dimname_len) :: dimname - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_water == moist_mixing_ratio - else - val_out = .false. - end if + call this%vertical_dimension(dimname) + is_2d = len_trim(dimname) == 0 - end subroutine ccp_is_moist + end function ccp_is_2d_var - !######################################################################## + !####################################################################### - subroutine ccp_is_wet(this, val_out, errcode, errmsg) + integer function ccp_const_index(this, errcode, errmsg) + ! Return this constituent's array index (or -1 of not assigned) - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_water == wet_mixing_ratio - else - val_out = .false. - end if + if (this%is_instantiated(errcode, errmsg)) then + ccp_const_index = this%const_ind + else + ccp_const_index = int_unassigned + end if - end subroutine ccp_is_wet + end function ccp_const_index - !######################################################################## + !####################################################################### - subroutine ccp_min_val(this, val_out, errcode, errmsg) + subroutine ccp_set_const_index(this, index, errcode, errmsg) + ! Set this constituent's index in the master constituent array + ! It is an error to try to set an index if it is already set - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + integer, intent(in) :: index + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), parameter :: subname = 'ccp_set_const_index' - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%min_val + if (this%is_instantiated(errcode, errmsg)) then + if (this%const_ind == int_unassigned) then + this%const_ind = index else - val_out = kphys_unassigned + call append_errvars(1, "ccpp_constituent_properties_t const index " // & + "is already set", subname, errcode=errcode, errmsg=errmsg) end if + end if - end subroutine ccp_min_val + end subroutine ccp_set_const_index - !######################################################################## + !####################################################################### - subroutine ccp_set_min_val(this, min_value, errcode, errmsg) - ! Set the minimum value of this particular constituent. - ! If this subroutine is never used then the minimum - ! value defaults to zero. + subroutine ccp_set_thermo_active(this, thermo_flag, errcode, errmsg) + ! Set whether this constituent is thermodynamically active, which + ! means that certain physics schemes will use this constitutent + ! when calculating thermodynamic quantities (e.g. enthalpy). - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - real(kind_phys), intent(in) :: min_value - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + logical, intent(in) :: thermo_flag + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + !Set thermodynamically active flag for this constituent: + if (this%is_instantiated(errcode, errmsg)) then + this%thermo_active = thermo_flag + end if + + end subroutine ccp_set_thermo_active + + !####################################################################### + + subroutine ccp_set_water_species(this, water_flag, errcode, errmsg) + ! Set whether this constituent is a water species, which means + ! that this constituent represents a particular phase or type + ! of water in the atmosphere. + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + logical, intent(in) :: water_flag + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + !Set water species flag for this constituent: + if (this%is_instantiated(errcode, errmsg)) then + this%water_species = water_flag + end if + + end subroutine ccp_set_water_species + + !####################################################################### + + subroutine ccp_is_thermo_active(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + !If instantiated then check if constituent is + !thermodynamically active, otherwise return false: + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%thermo_active + else + val_out = .false. + end if + end subroutine ccp_is_thermo_active + + !####################################################################### + + subroutine ccp_is_water_species(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + !If instantiated then check if constituent is + !a water species, otherwise return false: + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%water_species + else + val_out = .false. + end if + end subroutine ccp_is_water_species + + !####################################################################### + + subroutine ccp_is_advected(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%advected + else + val_out = .false. + end if + end subroutine ccp_is_advected + + !####################################################################### + + subroutine ccp_is_equivalent(this, oconst, equiv, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + type(ccpp_constituent_properties_t), intent(in) :: oconst + logical, intent(out) :: equiv + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg) .and. & + oconst%is_instantiated(errcode, errmsg)) then + equiv = (trim(this%var_std_name) == trim(oconst%var_std_name)) .and. & + (trim(this%var_long_name) == trim(oconst%var_long_name)) .and. & + (trim(this%vert_dim) == trim(oconst%vert_dim)) .and. & + (trim(this%var_units) == trim(oconst%var_units)) .and. & + (this%advected .eqv. oconst%advected) .and. & + (this%const_default_value == oconst%const_default_value) .and. & + (this%min_val == oconst%min_val) .and. & + (this%molar_mass_val == oconst%molar_mass_val) .and. & + (this%thermo_active .eqv. oconst%thermo_active) .and. & + (this%const_water == oconst%const_water) .and. & + (this%water_species .eqv. oconst%water_species) + else + equiv = .false. + end if + + end subroutine ccp_is_equivalent + + !######################################################################## + + subroutine ccp_is_mass_mixing_ratio(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_type == mass_mixing_ratio + else + val_out = .false. + end if + end subroutine ccp_is_mass_mixing_ratio + + !######################################################################## + + subroutine ccp_is_volume_mixing_ratio(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_type == volume_mixing_ratio + else + val_out = .false. + end if + end subroutine ccp_is_volume_mixing_ratio + + !######################################################################## + + subroutine ccp_is_number_concentration(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_type == number_concentration + else + val_out = .false. + end if + end subroutine ccp_is_number_concentration + + !######################################################################## - !Set minimum allowed value for this constituent: - if (this%is_instantiated(errcode, errmsg)) then - this%min_val = min_value - end if + subroutine ccp_is_dry(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_water == dry_mixing_ratio + else + val_out = .false. + end if - end subroutine ccp_set_min_val + end subroutine ccp_is_dry - !######################################################################## + !######################################################################## - subroutine ccp_molar_mass(this, val_out, errcode, errmsg) + subroutine ccp_is_moist(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_water == moist_mixing_ratio + else + val_out = .false. + end if - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%molar_mass_val - else - val_out = kphys_unassigned - end if + end subroutine ccp_is_moist - end subroutine ccp_molar_mass + !######################################################################## - !######################################################################## + subroutine ccp_is_wet(this, val_out, errcode, errmsg) - subroutine ccp_set_molar_mass(this, molar_mass, errcode, errmsg) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(inout) :: this - real(kind_phys), intent(in) :: molar_mass - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_water == wet_mixing_ratio + else + val_out = .false. + end if - if (this%is_instantiated(errcode, errmsg)) then - this%molar_mass_val = molar_mass - end if + end subroutine ccp_is_wet - end subroutine ccp_set_molar_mass + !######################################################################## - !######################################################################## + subroutine ccp_min_val(this, val_out, errcode, errmsg) - subroutine ccp_default_value(this, val_out, errcode, errmsg) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%min_val + else + val_out = kphys_unassigned + end if - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_default_value - else - val_out = kphys_unassigned - end if + end subroutine ccp_min_val - end subroutine ccp_default_value + !######################################################################## - !######################################################################## + subroutine ccp_set_min_val(this, min_value, errcode, errmsg) + ! Set the minimum value of this particular constituent. + ! If this subroutine is never used then the minimum + ! value defaults to zero. - subroutine ccp_has_default(this, val_out, errcode, errmsg) + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + real(kind=kind_phys), intent(in) :: min_value + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccp_has_default' + !Set minimum allowed value for this constituent: + if (this%is_instantiated(errcode, errmsg)) then + this%min_val = min_value + end if - if (this%is_instantiated(errcode, errmsg)) then - val_out = this%const_default_value /= kphys_unassigned - else - val_out = .false. - end if - - end subroutine ccp_has_default - - !######################################################################## - - logical function ccp_is_match(this, comp_props) result(is_match) - ! Return .true. iff the constituent's properties match the checked - ! attributes of another constituent properties object - ! Since this is a private function, error checking for locked status - ! is *not* performed. - - ! Dummy arguments - class(ccpp_constituent_properties_t), intent(in) :: this - type(ccpp_constituent_properties_t), intent(in) :: comp_props - ! Local variable - logical :: val, comp_val - character(len=stdname_len) :: char_val, char_comp_val - logical :: check - - ! By default, every constituent is a match - is_match = .true. - ! Check: advected, thermo_active, water_species, units - call this%is_advected(val) - call comp_props%is_advected(comp_val) - if (val .neqv. comp_val) then - is_match = .false. - return - end if + end subroutine ccp_set_min_val - call this%is_thermo_active(val) - call comp_props%is_thermo_active(comp_val) - if (val .neqv. comp_val) then - is_match = .false. - return - end if + !######################################################################## - call this%is_water_species(val) - call comp_props%is_water_species(comp_val) - if (val .neqv. comp_val) then - is_match = .false. - return - end if + subroutine ccp_molar_mass(this, val_out, errcode, errmsg) - call this%units(char_val) - call comp_props%units(char_comp_val) - if (trim(char_val) /= trim(char_comp_val)) then - is_match = .false. - return - end if + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg - end function ccp_is_match - - !######################################################################## - ! - ! CCPP_MODEL_CONSTITUENTS_T (constituent field data) methods - ! - !######################################################################## - - logical function ccp_model_const_locked(this, errcode, errmsg, warn_func) - ! Return .true. iff is locked (i.e., ready to use) - ! Optionally fill out and if object not initialized - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), optional, intent(in) :: warn_func - ! Local variable - character(len=*), parameter :: subname = 'ccp_model_const_locked' - - call initialize_errvars(errcode, errmsg) - ccp_model_const_locked = .false. - ! Use an initialized hash table as double check - if (this%hash_table%is_initialized()) then - ccp_model_const_locked = this%table_locked .and. this%data_locked - if ( (.not. (this%table_locked .and. this%data_locked)) .and. & - present(errmsg) .and. present(warn_func)) then - ! Write a warning as a courtesy to calling function but do not set - ! errcode (let caller decide). - write(errmsg, *) trim(warn_func), & - ' WARNING: Model constituents not ready to use' - end if - else - call append_errvars(1, "WARNING: Model constituents not initialized", & - subname, errcode=errcode, errmsg=errmsg, caller=warn_func) - end if - - end function ccp_model_const_locked - - !######################################################################## - - logical function ccp_model_const_props_locked(this, errcode, errmsg, warn_func) - ! Return .true. iff 's constituent properties are ready to use - ! Optionally fill out and if object not initialized - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), optional, intent(in) :: warn_func - ! Local variable - character(len=*), parameter :: subname = 'ccp_model_const_table_locked' - - call initialize_errvars(errcode, errmsg) - ccp_model_const_props_locked = .false. - ! Use an initialized hash table as double check - if (this%hash_table%is_initialized()) then - ccp_model_const_props_locked = this%table_locked - if ( .not. this%table_locked .and. & - present(errmsg) .and. present(warn_func)) then - ! Write a warning as a courtesy to calling function but do not set - ! errcode (let caller decide). - write(errmsg, *) trim(warn_func), & - ' WARNING: Model constituent properties not ready to use' - end if - else - call append_errvars(1, & - "WARNING: Model constituent properties not initialized", & - subname, errcode=errcode, errmsg=errmsg, caller=warn_func) - end if - - end function ccp_model_const_props_locked - - !######################################################################## - - logical function ccp_model_const_data_locked(this, errcode, errmsg, warn_func) - ! Return .true. iff 's data are ready to use - ! Optionally fill out and if object not initialized - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), optional, intent(in) :: warn_func - ! Local variable - character(len=*), parameter :: subname = 'ccp_model_const_data_locked' - - call initialize_errvars(errcode, errmsg) - ccp_model_const_data_locked = .false. - ! Use an initialized hash table as double check - if (this%hash_table%is_initialized()) then - ccp_model_const_data_locked = this%data_locked - if ( .not. this%data_locked .and. & - present(errmsg) .and. present(warn_func)) then - ! Write a warning as a courtesy to calling function but do not set - ! errcode (let caller decide). - write(errmsg, *) trim(warn_func), & - ' WARNING: Model constituent data not ready to use' - end if - else - call append_errvars(1, & - "WARNING: Model constituent data not initialized", & - subname, errcode=errcode, errmsg=errmsg, caller=warn_func) - end if + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%molar_mass_val + else + val_out = kphys_unassigned + end if + + end subroutine ccp_molar_mass + + !######################################################################## + + subroutine ccp_set_molar_mass(this, molar_mass, errcode, errmsg) - end function ccp_model_const_data_locked - - !######################################################################## - - logical function ccp_model_const_okay_to_add(this, errcode, errmsg, & - warn_func) - ! Return .true. iff is initialized and not locked - ! Optionally fill out and if the conditions - ! are not met. - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - character(len=*), optional, intent(in) :: warn_func - ! Local variable - character(len=*), parameter :: subname = 'ccp_model_const_okay_to_add' - - ccp_model_const_okay_to_add = this%hash_table%is_initialized() - if (ccp_model_const_okay_to_add) then - ccp_model_const_okay_to_add = .not. (this%const_props_locked(errcode=errcode, & - errmsg=errmsg, warn_func=subname) .or. this%const_data_locked(errcode=errcode, & - errmsg=errmsg, warn_func=subname)) - if (.not. ccp_model_const_okay_to_add) then - call append_errvars(1, & - "WARNING: Model constituents are locked", & - subname, errcode=errcode, errmsg=errmsg, caller=warn_func) - end if - else - call append_errvars(1, & - "WARNING: Model constituents not initialized", & - subname, errcode=errcode, errmsg=errmsg, caller=warn_func) - end if - - end function ccp_model_const_okay_to_add - - !######################################################################## - - subroutine ccp_model_const_add_metadata(this, field_data, errcode, errmsg) - ! Add a constituent's metadata to the master hash table - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - type(ccpp_constituent_properties_t), target, intent(in) :: field_data - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - character(len=errmsg_len) :: error - character(len=*), parameter :: subname = 'ccp_model_const_add_metadata' - type(ccpp_constituent_properties_t), pointer :: cprop => NULL() - character(len=stdname_len) :: standard_name - logical :: match - - if (this%okay_to_add(errcode=errcode, errmsg=errmsg, & - warn_func=subname)) then - error = '' - ! Check to see if standard name is already in the table - call field_data%standard_name(standard_name, errcode, errmsg) - cprop => this%find_const(standard_name) - if (associated(cprop)) then - ! Standard name already in table, let's see if the existing constituent is the same - match = cprop%is_match(field_data) - if (match) then - ! Existing constituent is a match - no need to throw an error, just don't add - return - else - ! Existing constituent is not a match - this is an error - call append_errvars(1, "ERROR: Trying to add constituent " // & - trim(standard_name) // " but an incompatible" // & - " constituent with this name already exists", subname, & - errcode=errcode, errmsg=errmsg) - return - end if - end if - call this%hash_table%add_hash_key(field_data, error) - if (len_trim(error) > 0) then - call append_errvars(1, trim(error), subname, errcode=errcode, errmsg=errmsg) - else - ! If we get here we are successful, add to variable count - if (field_data%is_layer_var()) then - this%num_layer_vars = this%num_layer_vars + 1 - else - if (present(errmsg)) then - call field_data%vertical_dimension(error, & - errcode=errcode, errmsg=errmsg) - if (errcode /= 0) then - call append_errvars(1, & - "ERROR: Unknown vertical dimension, '" // & - trim(error) // "'", subname, & - errcode=errcode, errmsg=errmsg) - end if - end if - end if - end if - else - call append_errvars(1, "WARNING: Model constituents are locked", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccp_model_const_add_metadata - - !######################################################################## - - subroutine ccp_model_const_initialize(this, num_elements) - ! Initialize hash table, is total number of elements - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - integer, intent(in) :: num_elements - ! Local variable - integer :: tbl_size - - ! Clear any data - call this%reset() - ! Figure a log base 2 for initializing hash table - tbl_size = num_elements * 10 ! Hash padding - tbl_size = int((log(real(tbl_size, kind_phys)) / log(2.0_kind_phys)) + & - 1.0_kind_phys) - ! Initialize hash table - call this%hash_table%initialize(tbl_size) - this%table_locked = .false. - - end subroutine ccp_model_const_initialize - - !######################################################################## - - function ccp_model_const_find_const(this, standard_name, errcode, errmsg) & - result(cprop) - ! Return a constituent with key, , from the hash table - ! must be locked to execute this function - ! Since this is a private function, error checking for locked status - ! is *not* performed. - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - character(len=*), intent(in) :: standard_name - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - type(ccpp_constituent_properties_t), pointer :: cprop - ! Local variables - class(ccpp_hashable_t), pointer :: hval - character(len=errmsg_len) :: error - character(len=*), parameter :: subname = 'ccp_model_const_find_const' - - nullify(cprop) - - hval => this%hash_table%table_value(standard_name, errmsg=error) - if (len_trim(error) > 0) then - call append_errvars(1, trim(error), subname, & + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(inout) :: this + real(kind=kind_phys), intent(in) :: molar_mass + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + this%molar_mass_val = molar_mass + end if + + end subroutine ccp_set_molar_mass + + !######################################################################## + + subroutine ccp_default_value(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_default_value + else + val_out = kphys_unassigned + end if + + end subroutine ccp_default_value + + !######################################################################## + + subroutine ccp_has_default(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccp_has_default' + + if (this%is_instantiated(errcode, errmsg)) then + val_out = this%const_default_value /= kphys_unassigned + else + val_out = .false. + end if + + end subroutine ccp_has_default + + !######################################################################## + + logical function ccp_is_match(this, comp_props) result(is_match) + ! Return .true. iff the constituent's properties match the checked + ! attributes of another constituent properties object + ! Since this is a private function, error checking for locked status + ! is *not* performed. + + ! Dummy arguments + class(ccpp_constituent_properties_t), intent(in) :: this + type(ccpp_constituent_properties_t), intent(in) :: comp_props + ! Local variable + logical :: val, comp_val + character(len=stdname_len) :: char_val, char_comp_val + logical :: check + + ! By default, every constituent is a match + is_match = .true. + ! Check: advected, thermo_active, water_species, units + call this%is_advected(val) + call comp_props%is_advected(comp_val) + if (val .neqv. comp_val) then + is_match = .false. + return + end if + + call this%is_thermo_active(val) + call comp_props%is_thermo_active(comp_val) + if (val .neqv. comp_val) then + is_match = .false. + return + end if + + call this%is_water_species(val) + call comp_props%is_water_species(comp_val) + if (val .neqv. comp_val) then + is_match = .false. + return + end if + + call this%units(char_val) + call comp_props%units(char_comp_val) + if (trim(char_val) /= trim(char_comp_val)) then + is_match = .false. + return + end if + + end function ccp_is_match + + !######################################################################## + ! + ! CCPP_MODEL_CONSTITUENTS_T (constituent field data) methods + ! + !######################################################################## + + logical function ccp_model_const_locked(this, errcode, errmsg, warn_func) + ! Return .true. iff is locked (i.e., ready to use) + ! Optionally fill out and if object not initialized + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), optional, intent(in) :: warn_func + ! Local variable + character(len=*), parameter :: subname = 'ccp_model_const_locked' + + call initialize_errvars(errcode, errmsg) + ccp_model_const_locked = .false. + ! Use an initialized hash table as double check + if (this%hash_table%is_initialized()) then + ccp_model_const_locked = this%table_locked .and. this%data_locked + if ((.not.(this%table_locked .and. this%data_locked)) .and. & + present(errmsg) .and. present(warn_func)) then + ! Write a warning as a courtesy to calling function but do not set + ! errcode (let caller decide). + write(errmsg, *) trim(warn_func), & + ' WARNING: Model constituents not ready to use' + end if + else + call append_errvars(1, "WARNING: Model constituents not initialized", & + subname, errcode=errcode, errmsg=errmsg, caller=warn_func) + end if + + end function ccp_model_const_locked + + !######################################################################## + + logical function ccp_model_const_props_locked(this, errcode, errmsg, warn_func) + ! Return .true. iff 's constituent properties are ready to use + ! Optionally fill out and if object not initialized + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), optional, intent(in) :: warn_func + ! Local variable + character(len=*), parameter :: subname = 'ccp_model_const_table_locked' + + call initialize_errvars(errcode, errmsg) + ccp_model_const_props_locked = .false. + ! Use an initialized hash table as double check + if (this%hash_table%is_initialized()) then + ccp_model_const_props_locked = this%table_locked + if (.not.this%table_locked .and. & + present(errmsg) .and. present(warn_func)) then + ! Write a warning as a courtesy to calling function but do not set + ! errcode (let caller decide). + write(errmsg, *) trim(warn_func), & + ' WARNING: Model constituent properties not ready to use' + end if + else + call append_errvars(1, & + "WARNING: Model constituent properties not initialized", & + subname, errcode=errcode, errmsg=errmsg, caller=warn_func) + end if + + end function ccp_model_const_props_locked + + !######################################################################## + + logical function ccp_model_const_data_locked(this, errcode, errmsg, warn_func) + ! Return .true. iff 's data are ready to use + ! Optionally fill out and if object not initialized + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), optional, intent(in) :: warn_func + ! Local variable + character(len=*), parameter :: subname = 'ccp_model_const_data_locked' + + call initialize_errvars(errcode, errmsg) + ccp_model_const_data_locked = .false. + ! Use an initialized hash table as double check + if (this%hash_table%is_initialized()) then + ccp_model_const_data_locked = this%data_locked + if (.not.this%data_locked .and. & + present(errmsg) .and. present(warn_func)) then + ! Write a warning as a courtesy to calling function but do not set + ! errcode (let caller decide). + write(errmsg, *) trim(warn_func), & + ' WARNING: Model constituent data not ready to use' + end if + else + call append_errvars(1, & + "WARNING: Model constituent data not initialized", & + subname, errcode=errcode, errmsg=errmsg, caller=warn_func) + end if + + end function ccp_model_const_data_locked + + !######################################################################## + + logical function ccp_model_const_okay_to_add(this, errcode, errmsg, & + warn_func) + ! Return .true. iff is initialized and not locked + ! Optionally fill out and if the conditions + ! are not met. + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + character(len=*), optional, intent(in) :: warn_func + ! Local variable + character(len=*), parameter :: subname = 'ccp_model_const_okay_to_add' + + ccp_model_const_okay_to_add = this%hash_table%is_initialized() + if (ccp_model_const_okay_to_add) then + ccp_model_const_okay_to_add = .not.(this%const_props_locked(errcode=errcode, & + errmsg=errmsg, warn_func=subname) .or. this%const_data_locked(errcode=errcode, & + errmsg=errmsg, warn_func=subname)) + if (.not.ccp_model_const_okay_to_add) then + call append_errvars(1, & + "WARNING: Model constituents are locked", & + subname, errcode=errcode, errmsg=errmsg, caller=warn_func) + end if + else + call append_errvars(1, & + "WARNING: Model constituents not initialized", & + subname, errcode=errcode, errmsg=errmsg, caller=warn_func) + end if + + end function ccp_model_const_okay_to_add + + !######################################################################## + + subroutine ccp_model_const_add_metadata(this, field_data, errcode, errmsg) + ! Add a constituent's metadata to the master hash table + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + type(ccpp_constituent_properties_t), target, intent(in) :: field_data + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + character(len=errmsg_len) :: error + character(len=*), parameter :: subname = 'ccp_model_const_add_metadata' + type(ccpp_constituent_properties_t), pointer :: cprop => null() + character(len=stdname_len) :: standard_name + logical :: match + + if (this%okay_to_add(errcode=errcode, errmsg=errmsg, & + warn_func=subname)) then + error = '' + ! Check to see if standard name is already in the table + call field_data%standard_name(standard_name, errcode, errmsg) + cprop => this%find_const(standard_name) + if (associated(cprop)) then + ! Standard name already in table, let's see if the existing constituent is the same + match = cprop%is_match(field_data) + if (match) then + ! Existing constituent is a match - no need to throw an error, just don't add + return + else + ! Existing constituent is not a match - this is an error + call append_errvars(1, "ERROR: Trying to add constituent " // & + trim(standard_name) // " but an incompatible" // & + " constituent with this name already exists", subname, & errcode=errcode, errmsg=errmsg) - else - select type(hval) - type is (ccpp_constituent_properties_t) - cprop => hval - class default - call append_errvars(1, "ERROR: Bad hash table value " // & - trim(standard_name), subname, errcode=errcode, errmsg=errmsg) - end select + return + end if end if - - end function ccp_model_const_find_const - - !######################################################################## - - subroutine ccp_model_const_table_lock(this, errcode, errmsg) - ! Freeze hash table and initialize constituent properties - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: index_const - integer :: index_advect - integer :: num_vars - integer :: astat - integer :: errcode_local - logical :: check - type(ccpp_hash_iterator_t) :: hiter - class(ccpp_hashable_t), pointer :: hval - type(ccpp_constituent_properties_t), pointer :: cprop - character(len=dimname_len) :: dimname - character(len=*), parameter :: subname = 'ccp_model_const_table_lock' - - astat = 0 - errcode_local = 0 - if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - call append_errvars(1, & - "WARNING: Model constituents properties already locked, ignoring", & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = 1 + call this%hash_table%add_hash_key(field_data, error) + if (len_trim(error) > 0) then + call append_errvars(1, trim(error), subname, errcode=errcode, errmsg=errmsg) else - ! Make sure everything is really initialized - call this%reset(clear_hash_table=.false.) - this%num_advected_vars = 0 - ! Allocate the constituent array - num_vars = this%hash_table%num_values() - allocate(this%const_metadata(num_vars), stat=astat) - call handle_allocate_error(astat, 'const_metadata', & + ! If we get here we are successful, add to variable count + if (field_data%is_layer_var()) then + this%num_layer_vars = this%num_layer_vars + 1 + else + if (present(errmsg)) then + call field_data%vertical_dimension(error, & + errcode=errcode, errmsg=errmsg) + if (errcode /= 0) then + call append_errvars(1, & + "ERROR: Unknown vertical dimension, '" // & + trim(error) // "'", subname, & + errcode=errcode, errmsg=errmsg) + end if + end if + end if + end if + else + call append_errvars(1, "WARNING: Model constituents are locked", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccp_model_const_add_metadata + + !######################################################################## + + subroutine ccp_model_const_initialize(this, num_elements) + ! Initialize hash table, is total number of elements + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + integer, intent(in) :: num_elements + ! Local variable + integer :: tbl_size + + ! Clear any data + call this%reset() + ! Figure a log base 2 for initializing hash table + tbl_size = num_elements * 10 ! Hash padding + tbl_size = int((log(real(tbl_size, kind_phys)) / log(2.0_kind_phys)) + & + 1.0_kind_phys) + ! Initialize hash table + call this%hash_table%initialize(tbl_size) + this%table_locked = .false. + + end subroutine ccp_model_const_initialize + + !######################################################################## + + function ccp_model_const_find_const(this, standard_name, errcode, errmsg) & + result(cprop) + ! Return a constituent with key, , from the hash table + ! must be locked to execute this function + ! Since this is a private function, error checking for locked status + ! is *not* performed. + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + character(len=*), intent(in) :: standard_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + type(ccpp_constituent_properties_t), pointer :: cprop + ! Local variables + class(ccpp_hashable_t), pointer :: hval + character(len=errmsg_len) :: error + character(len=*), parameter :: subname = 'ccp_model_const_find_const' + + nullify(cprop) + + hval => this%hash_table%table_value(standard_name, errmsg=error) + if (len_trim(error) > 0) then + call append_errvars(1, trim(error), subname, & + errcode=errcode, errmsg=errmsg) + else + select type (hval) + type is (ccpp_constituent_properties_t) + cprop => hval + class default + call append_errvars(1, "ERROR: Bad hash table value " // & + trim(standard_name), subname, errcode=errcode, errmsg=errmsg) + end select + end if + + end function ccp_model_const_find_const + + !######################################################################## + + subroutine ccp_model_const_table_lock(this, errcode, errmsg) + ! Freeze hash table and initialize constituent properties + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: index_const + integer :: index_advect + integer :: num_vars + integer :: astat + integer :: errcode_local + logical :: check + type(ccpp_hash_iterator_t) :: hiter + class(ccpp_hashable_t), pointer :: hval + type(ccpp_constituent_properties_t), pointer :: cprop + character(len=dimname_len) :: dimname + character(len=*), parameter :: subname = 'ccp_model_const_table_lock' + + astat = 0 + errcode_local = 0 + if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + call append_errvars(1, & + "WARNING: Model constituents properties already locked, ignoring", & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = 1 + else + ! Make sure everything is really initialized + call this%reset(clear_hash_table=.false.) + this%num_advected_vars = 0 + ! Allocate the constituent array + num_vars = this%hash_table%num_values() + allocate(this%const_metadata(num_vars), stat=astat) + call handle_allocate_error(astat, 'const_metadata', & + subname, errcode=errcode, errmsg=errmsg) + ! We want to pack the advected constituents at the beginning of + ! the field array so we need to know how many there are + if (astat == 0) then + call hiter%initialize(this%hash_table) + do + if (hiter%valid()) then + hval => hiter%value() + select type (hval) + type is (ccpp_constituent_properties_t) + cprop => hval + call cprop%is_advected(check) + if (check) then + this%num_advected_vars = this%num_advected_vars + 1 + end if + end select + call hiter%next() + else + exit + end if + end do + ! Sanity check on num_advect + if (this%num_advected_vars > num_vars) then + call append_errvars(1, "ERROR: num_advected_vars index " // & + to_str(this%num_advected_vars) // & + " out of bounds " // to_str(num_vars), & subname, errcode=errcode, errmsg=errmsg) - ! We want to pack the advected constituents at the beginning of - ! the field array so we need to know how many there are - if (astat == 0) then - call hiter%initialize(this%hash_table) - do - if (hiter%valid()) then - hval => hiter%value() - select type(hval) - type is (ccpp_constituent_properties_t) - cprop => hval - call cprop%is_advected(check) - if (check) then - this%num_advected_vars = this%num_advected_vars + 1 - end if - end select - call hiter%next() - else + errcode_local = 1 + end if + end if + index_advect = 0 + index_const = this%num_advected_vars + ! Iterate through the hash table to find entries + if (errcode_local == 0) then + call hiter%initialize(this%hash_table) + do + if (hiter%valid()) then + hval => hiter%value() + select type (hval) + type is (ccpp_constituent_properties_t) + cprop => hval + call cprop%is_advected(check) + if (check) then + index_advect = index_advect + 1 + if (index_advect > this%num_advected_vars) then + call append_errvars(1, "ERROR: const a index " // & + to_str(index_advect) // " out of bounds " // & + to_str(this%num_advected_vars), & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 exit - end if - end do - ! Sanity check on num_advect - if (this%num_advected_vars > num_vars) then - call append_errvars(1, "ERROR: num_advected_vars index " // & - to_str(this%num_advected_vars) // & - " out of bounds " // to_str(num_vars), & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = 1 - end if - end if - index_advect = 0 - index_const = this%num_advected_vars - ! Iterate through the hash table to find entries - if (errcode_local == 0) then - call hiter%initialize(this%hash_table) - do - if (hiter%valid()) then - hval => hiter%value() - select type(hval) - type is (ccpp_constituent_properties_t) - cprop => hval - call cprop%is_advected(check) - if (check) then - index_advect = index_advect + 1 - if (index_advect > this%num_advected_vars) then - call append_errvars(1, "ERROR: const a index " // & - to_str(index_advect) // " out of bounds " // & - to_str(this%num_advected_vars), & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - exit - end if - call cprop%set_const_index(index_advect, & - errcode=errcode, errmsg=errmsg) - call this%const_metadata(index_advect)%set(cprop) - else - index_const = index_const + 1 - if (index_const > num_vars) then - call append_errvars(1, "ERROR: const v index " // & - to_str(index_const) // " out of bounds " // & - to_str(num_vars), subname, errcode=errcode, & - errmsg=errmsg) - errcode_local = errcode_local + 1 - exit - end if - call cprop%set_const_index(index_const, & - errcode=errcode, errmsg=errmsg) - call this%const_metadata(index_const)%set(cprop) - end if - ! Make sure this is a layer variable - if (.not. cprop%is_layer_var()) then - call cprop%vertical_dimension(dimname, & - errcode=errcode, errmsg=errmsg) - call append_errvars(1, "ERROR: Bad vertical dimension, '" // & - trim(dimname), subname, errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - exit - end if - class default - call append_errvars(1, "ERROR: Bad hash table value", & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - exit - end select - call hiter%next() - else + end if + call cprop%set_const_index(index_advect, & + errcode=errcode, errmsg=errmsg) + call this%const_metadata(index_advect)%set(cprop) + else + index_const = index_const + 1 + if (index_const > num_vars) then + call append_errvars(1, "ERROR: const v index " // & + to_str(index_const) // " out of bounds " // & + to_str(num_vars), subname, errcode=errcode, & + errmsg=errmsg) + errcode_local = errcode_local + 1 exit - end if - end do - ! Some size sanity checks - if (index_const /= this%hash_table%num_values()) then - call append_errvars(1, "ERROR: Too few constituents "// & - to_str(index_const) // " found in hash table " // & - to_str(this%hash_table%num_values()), subname, & + end if + call cprop%set_const_index(index_const, & errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - end if - if (index_advect /= this%num_advected_vars) then - call append_errvars(1, "ERROR: Too few advected constituents " // & - to_str(index_const) // " found in hash table " // & - to_str(this%hash_table%num_values()), subname, & + call this%const_metadata(index_const)%set(cprop) + end if + ! Make sure this is a layer variable + if (.not.cprop%is_layer_var()) then + call cprop%vertical_dimension(dimname, & errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - end if - if (present(errcode)) then - if (errcode /= 0) then - errcode_local = 1 - end if - end if - if (errcode_local == 0) then - this%table_locked = .true. - end if - end if - end if - - end subroutine ccp_model_const_table_lock - - !######################################################################## - - subroutine ccp_model_const_data_lock(this, ncols, num_layers, errcode, errmsg) - ! Freeze hash table and initialize constituent arrays - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - integer, intent(in) :: ncols - integer, intent(in) :: num_layers - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: astat, index, errcode_local - real(kind=kind_phys) :: default_value - real(kind=kind_phys) :: minvalue - character(len=*), parameter :: subname = 'ccp_model_const_data_lock' - - errcode_local = 0 - if (this%const_data_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - call append_errvars(1, & - "WARNING: Model constituent data already locked, ignoring", & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - else if (.not. this%const_props_locked(errcode=errcode, errmsg=errmsg, & - warn_func=subname)) then - call append_errvars(1, & - "WARNING: Model constituent properties not yet locked, ignoring", & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = errcode_local + 1 - else - allocate(this%vars_layer(ncols, num_layers, this%hash_table%num_values()), & - stat=astat) - call handle_allocate_error(astat, 'vars_layer', & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = astat - if (astat == 0) then - allocate(this%vars_layer_tend(ncols, num_layers, this%hash_table%num_values()), & - stat=astat) - call handle_allocate_error(astat, 'vars_layer_tend', & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = astat - end if - if (astat == 0) then - allocate(this%vars_minvalue(this%hash_table%num_values()), stat=astat) - call handle_allocate_error(astat, 'vars_minvalue', & - subname, errcode=errcode, errmsg=errmsg) - errcode_local = astat - end if - ! Initialize tendencies to 0 - this%vars_layer_tend(:,:,:) = 0._kind_phys - if (errcode_local == 0) then - this%num_layers = num_layers - do index = 1, this%hash_table%num_values() - !Set all constituents to their default values: - call this%const_metadata(index)%default_value(default_value, & - errcode, errmsg) - this%vars_layer(:,:,index) = default_value - - ! Also set the minimum allowed value array - call this%const_metadata(index)%minimum(minvalue, errcode, & - errmsg) - this%vars_minvalue(index) = minvalue - end do - end if - if (present(errcode)) then - if (errcode /= 0) then - errcode_local = 1 - end if - end if - if (errcode_local == 0) then - this%data_locked = .true. - end if - end if - - end subroutine ccp_model_const_data_lock - - !######################################################################## - - subroutine ccp_model_const_reset(this, clear_hash_table) - ! Empty (reset) the entire object - ! Optionally do not clear the hash table (and its data) - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(inout) :: this - logical, optional, intent(in) :: clear_hash_table - ! Local variables - logical :: clear_table - integer :: index - - if (present(clear_hash_table)) then - clear_table = clear_hash_table - else - clear_table = .true. - end if - if (allocated(this%vars_layer)) then - deallocate(this%vars_layer) - end if - if (allocated(this%vars_minvalue)) then - deallocate(this%vars_minvalue) - end if - if (allocated(this%vars_layer_tend)) then - deallocate(this%vars_layer_tend) - end if - if (allocated(this%const_metadata)) then - if (clear_table) then - do index = 1, size(this%const_metadata, 1) - call this%const_metadata(index)%deallocate() - end do - end if - deallocate(this%const_metadata) + call append_errvars(1, "ERROR: Bad vertical dimension, '" // & + trim(dimname), subname, errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + exit + end if + class default + call append_errvars(1, "ERROR: Bad hash table value", & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + exit + end select + call hiter%next() + else + exit + end if + end do + ! Some size sanity checks + if (index_const /= this%hash_table%num_values()) then + call append_errvars(1, "ERROR: Too few constituents " // & + to_str(index_const) // " found in hash table " // & + to_str(this%hash_table%num_values()), subname, & + errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + end if + if (index_advect /= this%num_advected_vars) then + call append_errvars(1, "ERROR: Too few advected constituents " // & + to_str(index_const) // " found in hash table " // & + to_str(this%hash_table%num_values()), subname, & + errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + end if + if (present(errcode)) then + if (errcode /= 0) then + errcode_local = 1 + end if + end if + if (errcode_local == 0) then + this%table_locked = .true. + end if + end if + end if + + end subroutine ccp_model_const_table_lock + + !######################################################################## + + subroutine ccp_model_const_data_lock(this, ncols, num_layers, errcode, errmsg) + ! Freeze hash table and initialize constituent arrays + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + integer, intent(in) :: ncols + integer, intent(in) :: num_layers + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: astat, index, errcode_local + real(kind=kind_phys) :: default_value + real(kind=kind_phys) :: minvalue + character(len=*), parameter :: subname = 'ccp_model_const_data_lock' + + errcode_local = 0 + if (this%const_data_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + call append_errvars(1, & + "WARNING: Model constituent data already locked, ignoring", & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + else if (.not.this%const_props_locked(errcode=errcode, errmsg=errmsg, & + warn_func=subname)) then + call append_errvars(1, & + "WARNING: Model constituent properties not yet locked, ignoring", & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = errcode_local + 1 + else + allocate(this%vars_layer(ncols, num_layers, this%hash_table%num_values()), & + stat=astat) + call handle_allocate_error(astat, 'vars_layer', & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = astat + if (astat == 0) then + allocate(this%vars_layer_tend(ncols, num_layers, this%hash_table%num_values()), & + stat=astat) + call handle_allocate_error(astat, 'vars_layer_tend', & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = astat + end if + if (astat == 0) then + allocate(this%vars_minvalue(this%hash_table%num_values()), stat=astat) + call handle_allocate_error(astat, 'vars_minvalue', & + subname, errcode=errcode, errmsg=errmsg) + errcode_local = astat + end if + ! Initialize tendencies to 0 + this%vars_layer_tend(:, :, :) = 0._kind_phys + if (errcode_local == 0) then + this%num_layers = num_layers + do index = 1, this%hash_table%num_values() + !Set all constituents to their default values: + call this%const_metadata(index)%default_value(default_value, & + errcode, errmsg) + this%vars_layer(:, :, index) = default_value + + ! Also set the minimum allowed value array + call this%const_metadata(index)%minimum(minvalue, errcode, & + errmsg) + this%vars_minvalue(index) = minvalue + end do end if + if (present(errcode)) then + if (errcode /= 0) then + errcode_local = 1 + end if + end if + if (errcode_local == 0) then + this%data_locked = .true. + end if + end if + + end subroutine ccp_model_const_data_lock + + !######################################################################## + + subroutine ccp_model_const_reset(this, clear_hash_table) + ! Empty (reset) the entire object + ! Optionally do not clear the hash table (and its data) + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(inout) :: this + logical, optional, intent(in) :: clear_hash_table + ! Local variables + logical :: clear_table + integer :: index + + if (present(clear_hash_table)) then + clear_table = clear_hash_table + else + clear_table = .true. + end if + if (allocated(this%vars_layer)) then + deallocate(this%vars_layer) + end if + if (allocated(this%vars_minvalue)) then + deallocate(this%vars_minvalue) + end if + if (allocated(this%vars_layer_tend)) then + deallocate(this%vars_layer_tend) + end if + if (allocated(this%const_metadata)) then if (clear_table) then - this%num_layer_vars = 0 - this%num_advected_vars = 0 - this%num_layers = 0 - call this%hash_table%clear() - end if - - end subroutine ccp_model_const_reset - - !######################################################################## - - logical function ccp_model_const_is_match(this, index, advected, & - thermo_active, water_species) result(is_match) - ! Return .true. iff the constituent at matches a pattern - ! Each (optional) property which is present represents something - ! which is required as part of a match. - ! Since this is a private function, error checking for locked status - ! is *not* performed. - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - integer, intent(in) :: index - logical, optional, intent(in) :: advected - logical, optional, intent(in) :: thermo_active - logical, optional, intent(in) :: water_species - ! Local variable - logical :: check - - ! By default, every constituent is a match - is_match = .true. - if (present(advected)) then - call this%const_metadata(index)%is_advected(check) - if (advected .neqv. check) then - is_match = .false. - end if - end if - - if (present(thermo_active)) then - call this%const_metadata(index)%is_thermo_active(check) - if (thermo_active .neqv. check) then - is_match = .false. - end if - end if - - if (present(water_species)) then - call this%const_metadata(index)%is_water_species(check) - if (water_species .neqv. check) then - is_match = .false. - end if - end if - - - end function ccp_model_const_is_match - - !######################################################################## - - subroutine ccp_model_const_num_match(this, nmatch, advected, thermo_active, & - water_species, errcode, errmsg) - ! Query number of constituents matching pattern - ! Each (optional) property which is present represents something - ! which is required as part of a match. - ! must be locked to execute this function - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - integer, intent(out) :: nmatch - logical, optional, intent(in) :: advected - logical, optional, intent(in) :: thermo_active - logical, optional, intent(in) :: water_species - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: index - character(len=*), parameter :: subname = "ccp_model_const_num_match" - - nmatch = 0 - if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - do index = 1, SIZE(this%const_metadata) - if (this%is_match(index, advected=advected, thermo_active=thermo_active, & - water_species=water_species)) then - nmatch = nmatch + 1 - end if - end do - end if - - end subroutine ccp_model_const_num_match - - !######################################################################## - - subroutine ccp_model_const_index(this, index, standard_name, errcode, errmsg) - ! Return index of metadata matching . - ! must be locked to execute this function - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - character(len=*), intent(in) :: standard_name - integer, intent(out) :: index - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - type(ccpp_constituent_properties_t), pointer :: cprop => NULL() - character(len=*), parameter :: subname = "ccp_model_const_index" - - if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - cprop => this%find_const(standard_name) - if (associated(cprop)) then - index = cprop%const_index() - else - index = int_unassigned - end if + do index = 1, size(this%const_metadata, 1) + call this%const_metadata(index)%deallocate() + end do + end if + deallocate(this%const_metadata) + end if + if (clear_table) then + this%num_layer_vars = 0 + this%num_advected_vars = 0 + this%num_layers = 0 + call this%hash_table%clear() + end if + + end subroutine ccp_model_const_reset + + !######################################################################## + + logical function ccp_model_const_is_match(this, index, advected, & + thermo_active, water_species) result(is_match) + ! Return .true. iff the constituent at matches a pattern + ! Each (optional) property which is present represents something + ! which is required as part of a match. + ! Since this is a private function, error checking for locked status + ! is *not* performed. + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + integer, intent(in) :: index + logical, optional, intent(in) :: advected + logical, optional, intent(in) :: thermo_active + logical, optional, intent(in) :: water_species + ! Local variable + logical :: check + + ! By default, every constituent is a match + is_match = .true. + if (present(advected)) then + call this%const_metadata(index)%is_advected(check) + if (advected .neqv. check) then + is_match = .false. + end if + end if + + if (present(thermo_active)) then + call this%const_metadata(index)%is_thermo_active(check) + if (thermo_active .neqv. check) then + is_match = .false. + end if + end if + + if (present(water_species)) then + call this%const_metadata(index)%is_water_species(check) + if (water_species .neqv. check) then + is_match = .false. + end if + end if + + end function ccp_model_const_is_match + + !######################################################################## + + subroutine ccp_model_const_num_match(this, nmatch, advected, thermo_active, & + water_species, errcode, errmsg) + ! Query number of constituents matching pattern + ! Each (optional) property which is present represents something + ! which is required as part of a match. + ! must be locked to execute this function + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + integer, intent(out) :: nmatch + logical, optional, intent(in) :: advected + logical, optional, intent(in) :: thermo_active + logical, optional, intent(in) :: water_species + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: index + character(len=*), parameter :: subname = "ccp_model_const_num_match" + + nmatch = 0 + if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + do index = 1, size(this%const_metadata) + if (this%is_match(index, advected=advected, thermo_active=thermo_active, & + water_species=water_species)) then + nmatch = nmatch + 1 + end if + end do + end if + + end subroutine ccp_model_const_num_match + + !######################################################################## + + subroutine ccp_model_const_index(this, index, standard_name, errcode, errmsg) + ! Return index of metadata matching . + ! must be locked to execute this function + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + character(len=*), intent(in) :: standard_name + integer, intent(out) :: index + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + type(ccpp_constituent_properties_t), pointer :: cprop => null() + character(len=*), parameter :: subname = "ccp_model_const_index" + + if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + cprop => this%find_const(standard_name) + if (associated(cprop)) then + index = cprop%const_index() else - index = int_unassigned - end if - - end subroutine ccp_model_const_index - - !######################################################################## - - subroutine ccp_model_const_metadata(this, standard_name, const_data, & - errcode, errmsg) - ! Return metadata matching standard name - ! must be locked to execute this function - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - character(len=*), intent(in) :: standard_name - type(ccpp_constituent_properties_t), intent(out) :: const_data - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - type(ccpp_constituent_properties_t), pointer :: cprop => NULL() - character(len=*), parameter :: subname = "ccp_model_const_metadata" - - if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - cprop => this%find_const(standard_name, errcode=errcode, errmsg=errmsg) - if (associated(cprop)) then - const_data = cprop - end if - end if - - end subroutine ccp_model_const_metadata - - !######################################################################## - - subroutine ccp_model_const_copy_in_3d(this, const_array, advected, & - thermo_active, water_species, errcode, errmsg) - ! Gather constituent fields matching pattern - ! Each (optional) property which is present represents something - ! which is required as part of a match. - ! must be locked to execute this function - - ! Dummy arguments - class(ccpp_model_constituents_t), intent(in) :: this - real(kind_phys), intent(out) :: const_array(:,:,:) - logical, optional, intent(in) :: advected - logical, optional, intent(in) :: thermo_active - logical, optional, intent(in) :: water_species - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: index ! const_metadata index - integer :: cindex ! const_array index - integer :: fld_ind ! const field index - integer :: max_cind ! Size of const_array - integer :: num_levels ! Levels of const_array - character(len=stdname_len) :: std_name - character(len=*), parameter :: subname = "ccp_model_const_copy_in_3d" - - if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - cindex = 0 - max_cind = SIZE(const_array, 3) - num_levels = SIZE(const_array, 2) - do index = 1, SIZE(this%const_metadata) - if (this%is_match(index, advected=advected, & - thermo_active=thermo_active, & - water_species=water_species)) then - ! See if we have room for another constituent - cindex = cindex + 1 - if (cindex > max_cind) then - call append_errvars(1, & - ": Too many constituents for ", & - subname, errcode=errcode, errmsg=errmsg) - exit - end if - ! Copy this constituent's field data to - call this%const_metadata(index)%const_index(fld_ind) - if (fld_ind /= index) then - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, ": ERROR: "// & - "bad field index, "//to_str(fld_ind)// & - " for '"//trim(std_name)//"', should have been "// & - to_str(index), subname, errcode=errcode, errmsg=errmsg) - exit - else if (this%const_metadata(index)%is_layer_var()) then - if (this%num_layers == num_levels) then - const_array(:,:,cindex) = this%vars_layer(:,:,fld_ind) - else - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, ": ERROR: "// & - "Wrong number of vertical levels for '"// & - trim(std_name)//"', "//to_str(num_levels)// & - ", expected "//to_str(this%num_layers), & - subname, errcode=errcode, errmsg=errmsg) - exit - end if - else - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, ": Unsupported var type,"// & - " wrong number of vertical levels for '"// & - trim(std_name)//"', "//to_str(num_levels)// & - ", expected"//to_str(this%num_layers), & - subname, errcode=errcode, errmsg=errmsg) - exit - end if - end if - end do - end if - - end subroutine ccp_model_const_copy_in_3d - - !######################################################################## - - subroutine ccp_model_const_copy_out_3d(this, const_array, advected, & - thermo_active, water_species, errcode, errmsg) - ! Update constituent fields matching pattern - ! Each (optional) property which is present represents something - ! which is required as part of a match. - ! must be locked to execute this function - - ! Dummy argument - class(ccpp_model_constituents_t), intent(inout) :: this - real(kind_phys), intent(in) :: const_array(:,:,:) - logical, optional, intent(in) :: advected - logical, optional, intent(in) :: thermo_active - logical, optional, intent(in) :: water_species - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: index ! const_metadata index - integer :: cindex ! const_array index - integer :: fld_ind ! const field index - integer :: max_cind ! Size of const_array - integer :: num_levels ! Levels of const_array - character(len=stdname_len) :: std_name - character(len=*), parameter :: subname = "ccp_model_const_copy_out_3d" - - if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - cindex = 0 - max_cind = SIZE(const_array, 3) - num_levels = SIZE(const_array, 2) - do index = 1, SIZE(this%const_metadata) - if (this%is_match(index, advected=advected, & - thermo_active=thermo_active, & - water_species=water_species)) then - ! See if we have room for another constituent - cindex = cindex + 1 - if (cindex > max_cind) then - call append_errvars(1, & - ": Too many constituents for ", & - subname, errcode=errcode, errmsg=errmsg) - exit - end if - ! Copy this field of to to constituent's field data - call this%const_metadata(index)%const_index(fld_ind) - if (fld_ind /= index) then - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, ": ERROR: "// & - "bad field index, "//to_str(fld_ind)// & - " for '"//trim(std_name)//"', should have been"// & - to_str(index), subname, errcode=errcode, errmsg=errmsg) - exit - else if (this%const_metadata(index)%is_layer_var()) then - if (this%num_layers == num_levels) then - this%vars_layer(:,:,fld_ind) = const_array(:,:,cindex) - else - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, & - ": Wrong number of vertical levels for '"// & - trim(std_name)//"', "//to_str(num_levels)// & - ", expected"//to_str(this%num_layers), & - subname, errcode=errcode, errmsg=errmsg) - exit - end if - else - call this%const_metadata(index)%standard_name(std_name) - call append_errvars(1, ": Unsupported var type,"// & - " wrong number of vertical levels for'"// & - trim(std_name)//"', "//to_str(num_levels)// & - ", expected "//to_str(this%num_layers), & - subname, errcode=errcode, errmsg=errmsg) - exit - end if + index = int_unassigned + end if + else + index = int_unassigned + end if + + end subroutine ccp_model_const_index + + !######################################################################## + + subroutine ccp_model_const_metadata(this, standard_name, const_data, & + errcode, errmsg) + ! Return metadata matching standard name + ! must be locked to execute this function + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + character(len=*), intent(in) :: standard_name + type(ccpp_constituent_properties_t), intent(out) :: const_data + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + type(ccpp_constituent_properties_t), pointer :: cprop => null() + character(len=*), parameter :: subname = "ccp_model_const_metadata" + + if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + cprop => this%find_const(standard_name, errcode=errcode, errmsg=errmsg) + if (associated(cprop)) then + const_data = cprop + end if + end if + + end subroutine ccp_model_const_metadata + + !######################################################################## + + subroutine ccp_model_const_copy_in_3d(this, const_array, advected, & + thermo_active, water_species, errcode, errmsg) + ! Gather constituent fields matching pattern + ! Each (optional) property which is present represents something + ! which is required as part of a match. + ! must be locked to execute this function + + ! Dummy arguments + class(ccpp_model_constituents_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: const_array(:, :, :) + logical, optional, intent(in) :: advected + logical, optional, intent(in) :: thermo_active + logical, optional, intent(in) :: water_species + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: index ! const_metadata index + integer :: cindex ! const_array index + integer :: fld_ind ! const field index + integer :: max_cind ! Size of const_array + integer :: num_levels ! Levels of const_array + character(len=stdname_len) :: std_name + character(len=*), parameter :: subname = "ccp_model_const_copy_in_3d" + + if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + cindex = 0 + max_cind = size(const_array, 3) + num_levels = size(const_array, 2) + do index = 1, size(this%const_metadata) + if (this%is_match(index, advected=advected, & + thermo_active=thermo_active, & + water_species=water_species)) then + ! See if we have room for another constituent + cindex = cindex + 1 + if (cindex > max_cind) then + call append_errvars(1, & + ": Too many constituents for ", & + subname, errcode=errcode, errmsg=errmsg) + exit + end if + ! Copy this constituent's field data to + call this%const_metadata(index)%const_index(fld_ind) + if (fld_ind /= index) then + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, ": ERROR: " // & + "bad field index, " // to_str(fld_ind) // & + " for '" // trim(std_name) // "', should have been " // & + to_str(index), subname, errcode=errcode, errmsg=errmsg) + exit + else if (this%const_metadata(index)%is_layer_var()) then + if (this%num_layers == num_levels) then + const_array(:, :, cindex) = this%vars_layer(:, :, fld_ind) + else + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, ": ERROR: " // & + "Wrong number of vertical levels for '" // & + trim(std_name) // "', " // to_str(num_levels) // & + ", expected " // to_str(this%num_layers), & + subname, errcode=errcode, errmsg=errmsg) + exit end if - end do - end if - - end subroutine ccp_model_const_copy_out_3d - - !######################################################################## - - function ccp_field_data_ptr(this) result(const_ptr) - ! Return pointer to constituent array (for use by host model) - - ! Dummy arguments - class(ccpp_model_constituents_t), target, intent(inout) :: this - real(kind_phys), pointer :: const_ptr(:,:,:) - ! Local variables - integer :: errcode - character(len=errmsg_len) :: errmsg - character(len=*), parameter :: subname = 'ccp_field_data_ptr' - - if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - const_ptr => this%vars_layer - else - ! We don't want output variables in a function so just nullify - ! See note above about creating a 'last_error' method - nullify(const_ptr) - end if - - end function ccp_field_data_ptr - - !######################################################################## - - function ccp_advected_data_ptr(this) result(const_ptr) - ! Return pointer to advected constituent array (for use by host model) - - ! Dummy arguments - class(ccpp_model_constituents_t), target, intent(inout) :: this - real(kind_phys), pointer :: const_ptr(:,:,:) - ! Local variables - integer :: errcode - character(len=errmsg_len) :: errmsg - character(len=*), parameter :: subname = 'ccp_advected_data_ptr' - - if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - const_ptr => this%vars_layer(:,:,1:this%num_advected_vars) - else - ! We don't want output variables in a function so just nullify - ! See note above about creating a 'last_error' method - nullify(const_ptr) - end if - - end function ccp_advected_data_ptr - - function ccp_constituent_props_ptr(this) result(const_ptr) - ! Return pointer to constituent properties array (for use by host model) - - ! Dummy arguments - class(ccpp_model_constituents_t), target, intent(inout) :: this - type(ccpp_constituent_prop_ptr_t), pointer :: const_ptr(:) - ! Local variables - integer :: errcode - character(len=errmsg_len) :: errmsg - character(len=*), parameter :: subname = 'ccp_constituent_props_ptr' - - if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then - const_ptr => this%const_metadata - else - ! We don't want output variables in a function so just nullify - ! See note above about creating a 'last_error' method - nullify(const_ptr) - end if - - end function ccp_constituent_props_ptr - - !######################################################################## - - !##################################### - ! ccpp_constituent_prop_ptr_t methods - !##################################### - - !####################################################################### - - subroutine ccpt_get_standard_name(this, std_name, errcode, errmsg) - ! Return this constituent's standard name - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - character(len=*), intent(out) :: std_name - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_get_standard_name' - - if (associated(this%prop)) then - call this%prop%standard_name(std_name, errcode, errmsg) - else - std_name = '' - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_get_standard_name - - !####################################################################### - - subroutine ccpt_get_long_name(this, long_name, errcode, errmsg) - ! Return this constituent's long name (description) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - character(len=*), intent(out) :: long_name - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_get_long_name' - - if (associated(this%prop)) then - call this%prop%long_name(long_name, errcode, errmsg) - else - long_name = '' - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_get_long_name - - !####################################################################### - - subroutine ccpt_get_units(this, units, errcode, errmsg) - ! Return this constituent's units - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - character(len=*), intent(out) :: units - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_get_units' - - if (associated(this%prop)) then - call this%prop%units(units, errcode, errmsg) - else - units = '' - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_get_units - - !####################################################################### - - subroutine ccpt_get_vertical_dimension(this, vert_dim, errcode, errmsg) - ! Return the standard name of this constituent's vertical dimension - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - character(len=*), intent(out) :: vert_dim - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_get_vertical_dimension' - - if (associated(this%prop)) then - if (this%prop%is_instantiated(errcode, errmsg)) then - call this%prop%vertical_dimension(vert_dim, errcode, errmsg) - end if - else - vert_dim = '' - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_get_vertical_dimension - - !####################################################################### - - logical function ccpt_is_layer_var(this) result(is_layer) - ! Return .true. iff this constituent has a layer vertical dimension - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - ! Local variables - character(len=dimname_len) :: dimname - character(len=*), parameter :: subname = 'ccpt_is_layer_var' - - if (associated(this%prop)) then - call this%prop%vertical_dimension(dimname) - is_layer = trim(dimname) == 'vertical_layer_dimension' - else - is_layer = .false. - end if - - end function ccpt_is_layer_var - - !####################################################################### - - logical function ccpt_is_interface_var(this) result(is_interface) - ! Return .true. iff this constituent has a interface vertical dimension - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - ! Local variables - character(len=dimname_len) :: dimname - character(len=*), parameter :: subname = 'ccpt_is_interface_var' - - if (associated(this%prop)) then - call this%prop%vertical_dimension(dimname) - is_interface = trim(dimname) == 'vertical_interface_dimension' - else - is_interface = .false. - end if - - end function ccpt_is_interface_var - - !####################################################################### - - logical function ccpt_is_2d_var(this) result(is_2d) - ! Return .true. iff this constituent has a 2d vertical dimension - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - ! Local variables - character(len=dimname_len) :: dimname - character(len=*), parameter :: subname = 'ccpt_is_2d_var' - - if (associated(this%prop)) then - call this%prop%vertical_dimension(dimname) - is_2d = len_trim(dimname) == 0 - else - is_2d = .false. - end if - - end function ccpt_is_2d_var - - !####################################################################### - - subroutine ccpt_const_index(this, index, errcode, errmsg) - ! Return this constituent's master index (or -1 of not assigned) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - integer, intent(out) :: index - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_const_index' - - if (associated(this%prop)) then - index = this%prop%const_index(errcode, errmsg) - else - index = int_unassigned - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_const_index - - !####################################################################### - - subroutine ccpt_is_thermo_active(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_thermo_active' - - if (associated(this%prop)) then - call this%prop%is_thermo_active(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_thermo_active - - !####################################################################### - - subroutine ccpt_is_water_species(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_water_species' - - if (associated(this%prop)) then - call this%prop%is_water_species(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_water_species - - !####################################################################### - - subroutine ccpt_is_advected(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_advected' - - if (associated(this%prop)) then - call this%prop%is_advected(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_advected - - !######################################################################## - - subroutine ccpt_is_mass_mixing_ratio(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_mass_mixing_ratio' - - if (associated(this%prop)) then - call this%prop%is_mass_mixing_ratio(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_mass_mixing_ratio - - !######################################################################## - - subroutine ccpt_is_volume_mixing_ratio(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_volume_mixing_ratio' - - if (associated(this%prop)) then - call this%prop%is_volume_mixing_ratio(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_volume_mixing_ratio - - !######################################################################## - - subroutine ccpt_is_number_concentration(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_number_concentration' - - if (associated(this%prop)) then - call this%prop%is_number_concentration(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_number_concentration - - !######################################################################## - - subroutine ccpt_is_dry(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_dry' - - if (associated(this%prop)) then - call this%prop%is_dry(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_dry - - !######################################################################## - - subroutine ccpt_is_moist(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_moist' - - if (associated(this%prop)) then - call this%prop%is_moist(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_moist - - !######################################################################## - - subroutine ccpt_is_wet(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_is_wet' - - if (associated(this%prop)) then - call this%prop%is_wet(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_is_wet - - !######################################################################## - - subroutine ccpt_min_val(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_min_val' - - if (associated(this%prop)) then - call this%prop%minimum(val_out, errcode, errmsg) - else - val_out = kphys_unassigned - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_min_val - - !######################################################################## - - subroutine ccpt_set_min_val(this, min_value, errcode, errmsg) - ! Set the minimum value of this particular constituent. - ! If this subroutine is never used then the minimum - ! value defaults to zero. - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - real(kind_phys), intent(in) :: min_value - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_set_min_val' - - !Set minimum value for this constituent: - if (associated(this%prop)) then - call this%prop%set_minimum(min_value, errcode, errmsg) - else - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_set_min_val - - !######################################################################## - - subroutine ccpt_molar_mass(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_molar_mass' - - if (associated(this%prop)) then - call this%prop%molar_mass(val_out, errcode, errmsg) - else - val_out = kphys_unassigned - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_molar_mass - - !######################################################################## - - subroutine ccpt_set_molar_mass(this, molar_mass, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - real(kind_phys), intent(in) :: molar_mass - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_set_molar_mass' - - if (associated(this%prop)) then - call this%prop%set_molar_mass(molar_mass, errcode, errmsg) - else - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_set_molar_mass - - !######################################################################## - - subroutine ccpt_default_value(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - real(kind_phys), intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_default_value' - - if (associated(this%prop)) then - call this%prop%default_value(val_out, errcode, errmsg) - else - val_out = kphys_unassigned - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_default_value - - !######################################################################## - - subroutine ccpt_has_default(this, val_out, errcode, errmsg) - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(in) :: this - logical, intent(out) :: val_out - integer, intent(out) :: errcode - character(len=*), intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_has_default' - - if (associated(this%prop)) then - call this%prop%has_default(val_out, errcode, errmsg) - else - val_out = .false. - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_has_default - - !######################################################################## - - subroutine ccpt_set(this, const_ptr, errcode, errmsg) - ! Set the pointer to , however, an error is recorded if - ! the pointer is already set. - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - type(ccpp_constituent_properties_t), pointer :: const_ptr - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variables - character(len=stdname_len) :: stdname - character(len=errmsg_len) :: errmsg2 - character(len=*), parameter :: subname = 'ccpt_set' - - call initialize_errvars(errcode, errmsg) - if (associated(this%prop)) then - call this%standard_name(stdname, errcode=errcode, errmsg=errmsg2) - if (errcode == 0) then - write(errmsg2, *) "Pointer already allocated as '", & - trim(stdname), "'" - end if - errcode = errcode + 1 - call append_errvars(1, trim(errmsg2), subname, errcode=errcode, & - errmsg=errmsg) - else - this%prop => const_ptr - end if - - end subroutine ccpt_set - - !######################################################################## - - subroutine ccpt_deallocate(this) - ! Deallocate the constituent object pointer if it is allocated. - - ! Dummy argument - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - - if (associated(this%prop)) then - call this%prop%deallocate() - deallocate(this%prop) - end if - nullify(this%prop) - - end subroutine ccpt_deallocate - - !####################################################################### - - subroutine ccpt_set_const_index(this, index, errcode, errmsg) - ! Set this constituent's index in the master constituent array - ! It is an error to try to set an index if it is already set - - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - integer, intent(in) :: index - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_set_const_index' - - if (associated(this%prop)) then - if (this%prop%is_instantiated(errcode, errmsg)) then - if (this%prop%const_ind == int_unassigned) then - this%prop%const_ind = index + else + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, ": Unsupported var type," // & + " wrong number of vertical levels for '" // & + trim(std_name) // "', " // to_str(num_levels) // & + ", expected" // to_str(this%num_layers), & + subname, errcode=errcode, errmsg=errmsg) + exit + end if + end if + end do + end if + + end subroutine ccp_model_const_copy_in_3d + + !######################################################################## + + subroutine ccp_model_const_copy_out_3d(this, const_array, advected, & + thermo_active, water_species, errcode, errmsg) + ! Update constituent fields matching pattern + ! Each (optional) property which is present represents something + ! which is required as part of a match. + ! must be locked to execute this function + + ! Dummy argument + class(ccpp_model_constituents_t), intent(inout) :: this + real(kind=kind_phys), intent(in) :: const_array(:, :, :) + logical, optional, intent(in) :: advected + logical, optional, intent(in) :: thermo_active + logical, optional, intent(in) :: water_species + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: index ! const_metadata index + integer :: cindex ! const_array index + integer :: fld_ind ! const field index + integer :: max_cind ! Size of const_array + integer :: num_levels ! Levels of const_array + character(len=stdname_len) :: std_name + character(len=*), parameter :: subname = "ccp_model_const_copy_out_3d" + + if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + cindex = 0 + max_cind = size(const_array, 3) + num_levels = size(const_array, 2) + do index = 1, size(this%const_metadata) + if (this%is_match(index, advected=advected, & + thermo_active=thermo_active, & + water_species=water_species)) then + ! See if we have room for another constituent + cindex = cindex + 1 + if (cindex > max_cind) then + call append_errvars(1, & + ": Too many constituents for ", & + subname, errcode=errcode, errmsg=errmsg) + exit + end if + ! Copy this field of to to constituent's field data + call this%const_metadata(index)%const_index(fld_ind) + if (fld_ind /= index) then + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, ": ERROR: " // & + "bad field index, " // to_str(fld_ind) // & + " for '" // trim(std_name) // "', should have been" // & + to_str(index), subname, errcode=errcode, errmsg=errmsg) + exit + else if (this%const_metadata(index)%is_layer_var()) then + if (this%num_layers == num_levels) then + this%vars_layer(:, :, fld_ind) = const_array(:, :, cindex) else - call append_errvars(1, "ccpp_constituent_prop_ptr_t "// & - "const index is already set", & - subname, errcode=errcode, errmsg=errmsg) + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, & + ": Wrong number of vertical levels for '" // & + trim(std_name) // "', " // to_str(num_levels) // & + ", expected" // to_str(this%num_layers), & + subname, errcode=errcode, errmsg=errmsg) + exit end if - end if - else - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if + else + call this%const_metadata(index)%standard_name(std_name) + call append_errvars(1, ": Unsupported var type," // & + " wrong number of vertical levels for'" // & + trim(std_name) // "', " // to_str(num_levels) // & + ", expected " // to_str(this%num_layers), & + subname, errcode=errcode, errmsg=errmsg) + exit + end if + end if + end do + end if + + end subroutine ccp_model_const_copy_out_3d + + !######################################################################## + + function ccp_field_data_ptr(this) result(const_ptr) + ! Return pointer to constituent array (for use by host model) + + ! Dummy arguments + class(ccpp_model_constituents_t), target, intent(inout) :: this + real(kind=kind_phys), pointer :: const_ptr(:, :, :) + ! Local variables + integer :: errcode + character(len=errmsg_len) :: errmsg + character(len=*), parameter :: subname = 'ccp_field_data_ptr' + + if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + const_ptr => this%vars_layer + else + ! We don't want output variables in a function so just nullify + ! See note above about creating a 'last_error' method + nullify(const_ptr) + end if + + end function ccp_field_data_ptr + + !######################################################################## + + function ccp_advected_data_ptr(this) result(const_ptr) + ! Return pointer to advected constituent array (for use by host model) + + ! Dummy arguments + class(ccpp_model_constituents_t), target, intent(inout) :: this + real(kind=kind_phys), pointer :: const_ptr(:, :, :) + ! Local variables + integer :: errcode + character(len=errmsg_len) :: errmsg + character(len=*), parameter :: subname = 'ccp_advected_data_ptr' + + if (this%locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + const_ptr => this%vars_layer(:, :, 1:this%num_advected_vars) + else + ! We don't want output variables in a function so just nullify + ! See note above about creating a 'last_error' method + nullify(const_ptr) + end if + + end function ccp_advected_data_ptr + + function ccp_constituent_props_ptr(this) result(const_ptr) + ! Return pointer to constituent properties array (for use by host model) + + ! Dummy arguments + class(ccpp_model_constituents_t), target, intent(inout) :: this + type(ccpp_constituent_prop_ptr_t), pointer :: const_ptr(:) + ! Local variables + integer :: errcode + character(len=errmsg_len) :: errmsg + character(len=*), parameter :: subname = 'ccp_constituent_props_ptr' + + if (this%const_props_locked(errcode=errcode, errmsg=errmsg, warn_func=subname)) then + const_ptr => this%const_metadata + else + ! We don't want output variables in a function so just nullify + ! See note above about creating a 'last_error' method + nullify(const_ptr) + end if + + end function ccp_constituent_props_ptr + + !######################################################################## + + !##################################### + ! ccpp_constituent_prop_ptr_t methods + !##################################### + + !####################################################################### + + subroutine ccpt_get_standard_name(this, std_name, errcode, errmsg) + ! Return this constituent's standard name + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + character(len=*), intent(out) :: std_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_get_standard_name' + + if (associated(this%prop)) then + call this%prop%standard_name(std_name, errcode, errmsg) + else + std_name = '' + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_get_standard_name + + !####################################################################### + + subroutine ccpt_get_long_name(this, long_name, errcode, errmsg) + ! Return this constituent's long name (description) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + character(len=*), intent(out) :: long_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_get_long_name' + + if (associated(this%prop)) then + call this%prop%long_name(long_name, errcode, errmsg) + else + long_name = '' + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_get_long_name + + !####################################################################### + + subroutine ccpt_get_units(this, units, errcode, errmsg) + ! Return this constituent's units + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + character(len=*), intent(out) :: units + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_get_units' + + if (associated(this%prop)) then + call this%prop%units(units, errcode, errmsg) + else + units = '' + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_get_units + + !####################################################################### + + subroutine ccpt_get_vertical_dimension(this, vert_dim, errcode, errmsg) + ! Return the standard name of this constituent's vertical dimension + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + character(len=*), intent(out) :: vert_dim + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_get_vertical_dimension' + + if (associated(this%prop)) then + if (this%prop%is_instantiated(errcode, errmsg)) then + call this%prop%vertical_dimension(vert_dim, errcode, errmsg) + end if + else + vert_dim = '' + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_get_vertical_dimension + + !####################################################################### + + logical function ccpt_is_layer_var(this) result(is_layer) + ! Return .true. iff this constituent has a layer vertical dimension + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + ! Local variables + character(len=dimname_len) :: dimname + character(len=*), parameter :: subname = 'ccpt_is_layer_var' + + if (associated(this%prop)) then + call this%prop%vertical_dimension(dimname) + is_layer = trim(dimname) == 'vertical_layer_dimension' + else + is_layer = .false. + end if - end subroutine ccpt_set_const_index + end function ccpt_is_layer_var - !####################################################################### + !####################################################################### - subroutine ccpt_set_thermo_active(this, thermo_flag, errcode, errmsg) - ! Set whether this constituent is thermodynamically active, which - ! means that certain physics schemes will use this constitutent - ! when calculating thermodynamic quantities (e.g. enthalpy). + logical function ccpt_is_interface_var(this) result(is_interface) + ! Return .true. iff this constituent has a interface vertical dimension - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - logical, intent(in) :: thermo_flag - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_set_thermo_active' + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + ! Local variables + character(len=dimname_len) :: dimname + character(len=*), parameter :: subname = 'ccpt_is_interface_var' - if (associated(this%prop)) then - if (this%prop%is_instantiated(errcode, errmsg)) then - this%prop%thermo_active = thermo_flag - end if - else - call append_errvars(1, ": invalid constituent pointer", & - subname, errcode=errcode, errmsg=errmsg) - end if + if (associated(this%prop)) then + call this%prop%vertical_dimension(dimname) + is_interface = trim(dimname) == 'vertical_interface_dimension' + else + is_interface = .false. + end if - end subroutine ccpt_set_thermo_active + end function ccpt_is_interface_var - !####################################################################### + !####################################################################### - subroutine ccpt_set_water_species(this, water_flag, errcode, errmsg) - ! Set whether this constituent is a water species, which means - ! that this constituent represents a particular phase or type - ! of water in the atmosphere. + logical function ccpt_is_2d_var(this) result(is_2d) + ! Return .true. iff this constituent has a 2d vertical dimension - ! Dummy arguments - class(ccpp_constituent_prop_ptr_t), intent(inout) :: this - logical, intent(in) :: water_flag - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - ! Local variable - character(len=*), parameter :: subname = 'ccpt_set_water_species' + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + ! Local variables + character(len=dimname_len) :: dimname + character(len=*), parameter :: subname = 'ccpt_is_2d_var' - if (associated(this%prop)) then - if (this%prop%is_instantiated(errcode, errmsg)) then - this%prop%water_species = water_flag - end if - else - call append_errvars(1, ": invalid constituent pointer", & + if (associated(this%prop)) then + call this%prop%vertical_dimension(dimname) + is_2d = len_trim(dimname) == 0 + else + is_2d = .false. + end if + + end function ccpt_is_2d_var + + !####################################################################### + + subroutine ccpt_const_index(this, index, errcode, errmsg) + ! Return this constituent's master index (or -1 of not assigned) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + integer, intent(out) :: index + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_const_index' + + if (associated(this%prop)) then + index = this%prop%const_index(errcode, errmsg) + else + index = int_unassigned + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_const_index + + !####################################################################### + + subroutine ccpt_is_thermo_active(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_thermo_active' + + if (associated(this%prop)) then + call this%prop%is_thermo_active(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_thermo_active + + !####################################################################### + + subroutine ccpt_is_water_species(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_water_species' + + if (associated(this%prop)) then + call this%prop%is_water_species(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_water_species + + !####################################################################### + + subroutine ccpt_is_advected(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_advected' + + if (associated(this%prop)) then + call this%prop%is_advected(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_advected + + !######################################################################## + + subroutine ccpt_is_mass_mixing_ratio(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_mass_mixing_ratio' + + if (associated(this%prop)) then + call this%prop%is_mass_mixing_ratio(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_mass_mixing_ratio + + !######################################################################## + + subroutine ccpt_is_volume_mixing_ratio(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_volume_mixing_ratio' + + if (associated(this%prop)) then + call this%prop%is_volume_mixing_ratio(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_volume_mixing_ratio + + !######################################################################## + + subroutine ccpt_is_number_concentration(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_number_concentration' + + if (associated(this%prop)) then + call this%prop%is_number_concentration(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_number_concentration + + !######################################################################## + + subroutine ccpt_is_dry(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_dry' + + if (associated(this%prop)) then + call this%prop%is_dry(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_dry + + !######################################################################## + + subroutine ccpt_is_moist(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_moist' + + if (associated(this%prop)) then + call this%prop%is_moist(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_moist + + !######################################################################## + + subroutine ccpt_is_wet(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_is_wet' + + if (associated(this%prop)) then + call this%prop%is_wet(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_is_wet + + !######################################################################## + + subroutine ccpt_min_val(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_min_val' + + if (associated(this%prop)) then + call this%prop%minimum(val_out, errcode, errmsg) + else + val_out = kphys_unassigned + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_min_val + + !######################################################################## + + subroutine ccpt_set_min_val(this, min_value, errcode, errmsg) + ! Set the minimum value of this particular constituent. + ! If this subroutine is never used then the minimum + ! value defaults to zero. + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + real(kind=kind_phys), intent(in) :: min_value + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_set_min_val' + + !Set minimum value for this constituent: + if (associated(this%prop)) then + call this%prop%set_minimum(min_value, errcode, errmsg) + else + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_set_min_val + + !######################################################################## + + subroutine ccpt_molar_mass(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_molar_mass' + + if (associated(this%prop)) then + call this%prop%molar_mass(val_out, errcode, errmsg) + else + val_out = kphys_unassigned + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_molar_mass + + !######################################################################## + + subroutine ccpt_set_molar_mass(this, molar_mass, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + real(kind=kind_phys), intent(in) :: molar_mass + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_set_molar_mass' + + if (associated(this%prop)) then + call this%prop%set_molar_mass(molar_mass, errcode, errmsg) + else + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_set_molar_mass + + !######################################################################## + + subroutine ccpt_default_value(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + real(kind=kind_phys), intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_default_value' + + if (associated(this%prop)) then + call this%prop%default_value(val_out, errcode, errmsg) + else + val_out = kphys_unassigned + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_default_value + + !######################################################################## + + subroutine ccpt_has_default(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, intent(out) :: errcode + character(len=*), intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_has_default' + + if (associated(this%prop)) then + call this%prop%has_default(val_out, errcode, errmsg) + else + val_out = .false. + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_has_default + + !######################################################################## + + subroutine ccpt_set(this, const_ptr, errcode, errmsg) + ! Set the pointer to , however, an error is recorded if + ! the pointer is already set. + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + type(ccpp_constituent_properties_t), pointer :: const_ptr + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variables + character(len=stdname_len) :: stdname + character(len=errmsg_len) :: errmsg2 + character(len=*), parameter :: subname = 'ccpt_set' + + call initialize_errvars(errcode, errmsg) + if (associated(this%prop)) then + call this%standard_name(stdname, errcode=errcode, errmsg=errmsg2) + if (errcode == 0) then + write(errmsg2, *) "Pointer already allocated as '", & + trim(stdname), "'" + end if + errcode = errcode + 1 + call append_errvars(1, trim(errmsg2), subname, errcode=errcode, & + errmsg=errmsg) + else + this%prop => const_ptr + end if + + end subroutine ccpt_set + + !######################################################################## + + subroutine ccpt_deallocate(this) + ! Deallocate the constituent object pointer if it is allocated. + + ! Dummy argument + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + + if (associated(this%prop)) then + call this%prop%deallocate() + deallocate(this%prop) + end if + nullify(this%prop) + + end subroutine ccpt_deallocate + + !####################################################################### + + subroutine ccpt_set_const_index(this, index, errcode, errmsg) + ! Set this constituent's index in the master constituent array + ! It is an error to try to set an index if it is already set + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + integer, intent(in) :: index + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_set_const_index' + + if (associated(this%prop)) then + if (this%prop%is_instantiated(errcode, errmsg)) then + if (this%prop%const_ind == int_unassigned) then + this%prop%const_ind = index + else + call append_errvars(1, "ccpp_constituent_prop_ptr_t " // & + "const index is already set", & subname, errcode=errcode, errmsg=errmsg) - end if - - end subroutine ccpt_set_water_species + end if + end if + else + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_set_const_index + + !####################################################################### + + subroutine ccpt_set_thermo_active(this, thermo_flag, errcode, errmsg) + ! Set whether this constituent is thermodynamically active, which + ! means that certain physics schemes will use this constitutent + ! when calculating thermodynamic quantities (e.g. enthalpy). + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + logical, intent(in) :: thermo_flag + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_set_thermo_active' + + if (associated(this%prop)) then + if (this%prop%is_instantiated(errcode, errmsg)) then + this%prop%thermo_active = thermo_flag + end if + else + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_set_thermo_active + + !####################################################################### + + subroutine ccpt_set_water_species(this, water_flag, errcode, errmsg) + ! Set whether this constituent is a water species, which means + ! that this constituent represents a particular phase or type + ! of water in the atmosphere. + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + logical, intent(in) :: water_flag + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + ! Local variable + character(len=*), parameter :: subname = 'ccpt_set_water_species' + + if (associated(this%prop)) then + if (this%prop%is_instantiated(errcode, errmsg)) then + this%prop%water_species = water_flag + end if + else + call append_errvars(1, ": invalid constituent pointer", & + subname, errcode=errcode, errmsg=errmsg) + end if + + end subroutine ccpt_set_water_species end module ccpp_constituent_prop_mod diff --git a/src/ccpp_hash_table.F90 b/src/ccpp_hash_table.F90 index 147ca5f0..98e21816 100644 --- a/src/ccpp_hash_table.F90 +++ b/src/ccpp_hash_table.F90 @@ -1,520 +1,520 @@ !!XXgoldyXX: To do, statistics output module ccpp_hash_table - use ccpp_hashable, only: ccpp_hashable_t - - implicit none - private - - ! - ! Constants used in hashing function gen_hash_key. - ! - - integer, parameter :: gen_hash_key_offset = 21467 ! z'000053db' - - integer, parameter :: tbl_max_idx = 15 - integer, parameter, dimension(0:tbl_max_idx) :: tbl_gen_hash_key = & - (/ 61, 59, 53, 47, 43, 41, 37, 31, 29, 23, 17, 13, 11, 7, 3, 1 /) - - integer, parameter :: table_factor_size = 8 ! Table size / # entries - integer, parameter :: table_overflow_factor = 4 ! # entries / Overflow size - - type :: table_entry_t - ! Any table entry contains a key and a value - class(ccpp_hashable_t), pointer :: entry_value => NULL() - type(table_entry_t), pointer :: next => NULL() - contains - final :: finalize_table_entry - end type table_entry_t - - type, public :: ccpp_hash_table_t - ! ccpp_hash_table_t contains all information to build and use a hash table - ! It also keeps track of statistics such as collision frequency and size - integer, private :: table_size = -1 - integer, private :: key_offset = gen_hash_key_offset - type(table_entry_t), private, allocatable :: table(:) - ! Statistics - integer, private :: num_keys = 0 - integer, private :: num_key_collisions = 0 - integer, private :: max_collision = 0 - contains - procedure :: is_initialized => hash_table_is_initialized - procedure :: initialize => hash_table_initialize_table - procedure :: key_hash => hash_table_key_hash - procedure :: add_hash_key => hash_table_add_hash_key - procedure :: table_value => hash_table_table_value - procedure :: num_values => hash_table_num_values - procedure :: clear => hash_table_clear_table - end type ccpp_hash_table_t - - type, public :: ccpp_hash_iterator_t - ! ccpp_hash_iterator contains information allowing iteration through all - ! entries in a hash table - integer, private :: index = 0 - type(table_entry_t), private, pointer :: table_entry => NULL() - type(ccpp_hash_table_t), private, pointer :: hash_table => NULL() - contains - procedure :: initialize => hash_iterator_initialize - procedure :: key => hash_iterator_key - procedure :: next => hash_iterator_next_entry - procedure :: valid => hash_iterator_is_valid - procedure :: value => hash_iterator_value - end type ccpp_hash_iterator_t - - !! Private interfaces - private :: have_error ! Has a called routine detected an error? - private :: clear_optstring ! Clear a string, if present - -CONTAINS - - !####################################################################### - ! - ! Hash table methods - ! - !####################################################################### - - logical function have_error(errmsg) - ! Return .true. iff is present and contains text - - ! Dummy argument - character(len=*), optional, intent(in) :: errmsg - - have_error = present(errmsg) - if (have_error) then - have_error = len_trim(errmsg) > 0 + use ccpp_hashable, only: ccpp_hashable_t + + implicit none + private + + ! + ! Constants used in hashing function gen_hash_key. + ! + + integer, parameter :: gen_hash_key_offset = 21467 ! z'000053db' + + integer, parameter :: tbl_max_idx = 15 + integer, parameter, dimension(0:tbl_max_idx) :: tbl_gen_hash_key = & + (/ 61, 59, 53, 47, 43, 41, 37, 31, 29, 23, 17, 13, 11, 7, 3, 1 /) + + integer, parameter :: table_factor_size = 8 ! Table size / # entries + integer, parameter :: table_overflow_factor = 4 ! # entries / Overflow size + + type :: table_entry_t + ! Any table entry contains a key and a value + class(ccpp_hashable_t), pointer :: entry_value => null() + type(table_entry_t), pointer :: next => null() + contains + final :: finalize_table_entry + end type table_entry_t + + type, public :: ccpp_hash_table_t + ! ccpp_hash_table_t contains all information to build and use a hash table + ! It also keeps track of statistics such as collision frequency and size + integer, private :: table_size = -1 + integer, private :: key_offset = gen_hash_key_offset + type(table_entry_t), private, allocatable :: table(:) + ! Statistics + integer, private :: num_keys = 0 + integer, private :: num_key_collisions = 0 + integer, private :: max_collision = 0 + contains + procedure :: is_initialized => hash_table_is_initialized + procedure :: initialize => hash_table_initialize_table + procedure :: key_hash => hash_table_key_hash + procedure :: add_hash_key => hash_table_add_hash_key + procedure :: table_value => hash_table_table_value + procedure :: num_values => hash_table_num_values + procedure :: clear => hash_table_clear_table + end type ccpp_hash_table_t + + type, public :: ccpp_hash_iterator_t + ! ccpp_hash_iterator contains information allowing iteration through all + ! entries in a hash table + integer, private :: index = 0 + type(table_entry_t), private, pointer :: table_entry => null() + type(ccpp_hash_table_t), private, pointer :: hash_table => null() + contains + procedure :: initialize => hash_iterator_initialize + procedure :: key => hash_iterator_key + procedure :: next => hash_iterator_next_entry + procedure :: valid => hash_iterator_is_valid + procedure :: value => hash_iterator_value + end type ccpp_hash_iterator_t + + !! Private interfaces + private :: have_error ! Has a called routine detected an error? + private :: clear_optstring ! Clear a string, if present + +contains + + !####################################################################### + ! + ! Hash table methods + ! + !####################################################################### + + logical function have_error(errmsg) + ! Return .true. iff is present and contains text + + ! Dummy argument + character(len=*), optional, intent(in) :: errmsg + + have_error = present(errmsg) + if (have_error) then + have_error = len_trim(errmsg) > 0 + end if + end function have_error + + !####################################################################### + + subroutine clear_optstring(str) + ! clear if it is present + + ! Dummy argument + character(len=*), optional, intent(inout) :: str + + if (present(str)) then + str = '' + end if + end subroutine clear_optstring + + !####################################################################### + + elemental subroutine finalize_table_entry(te) + + ! Dummy argument + type(table_entry_t), intent(inout) :: te + ! Local variable + type(table_entry_t), pointer :: temp + + if (associated(te%entry_value)) then + nullify(te%entry_value) ! We may not own the memory + temp => te%next + nullify(te%next) + if (associated(temp)) then + deallocate(temp) + nullify(temp) end if - end function have_error - - !####################################################################### - - subroutine clear_optstring(str) - ! clear if it is present - - ! Dummy argument - character(len=*), optional, intent(inout) :: str - - if (present(str)) then - str = '' + end if + + end subroutine finalize_table_entry + + !####################################################################### + + logical function hash_table_is_initialized(this) + ! Return .true. iff is an initialized hash table + + ! Dummy argument + class(ccpp_hash_table_t) :: this + + hash_table_is_initialized = allocated(this%table) + + end function hash_table_is_initialized + + !####################################################################### + + subroutine hash_table_initialize_table(this, tbl_size, key_off) + ! Initialize this table. + + ! Dummy arguments + class(ccpp_hash_table_t) :: this + integer, intent(in) :: tbl_size ! new table size + integer, optional, intent(in) :: key_off ! key offset + + ! Clear this table so it can be initialized + if (allocated(this%table)) then + deallocate(this%table) + end if + this%num_keys = 0 + this%num_key_collisions = 0 + this%max_collision = 0 + ! Avoid too-large tables + this%table_size = ishft(1, min(tbl_size, bit_size(1) - 2)) + allocate(this%table(this%table_size)) + if (present(key_off)) then + this%key_offset = key_off + end if + end subroutine hash_table_initialize_table + + !####################################################################### + + integer function hash_table_key_hash(this, string, errmsg) result(hash_key) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Generate a hash key on the interval [0 .. tbl_hash_pri_sz-1] + ! given a character string. + ! + ! Algorithm is a variant of perl's internal hashing function. + ! + !----------------------------------------------------------------------- + ! + ! + ! Dummy Arguments: + ! + class(ccpp_hash_table_t) :: this + character(len=*), intent(in) :: string + character(len=*), optional, intent(out) :: errmsg + character(len=*), parameter :: subname = 'HASH_TABLE_KEY_HASH' + ! + ! Local. + ! + integer :: hash + integer :: index + integer :: ind_fact + integer :: hash_fact + + hash = this%key_offset + ind_fact = 0 + do index = 1, len_trim(string) + ind_fact = ind_fact + 1 + if (ind_fact > tbl_max_idx) then + ind_fact = 1 end if - end subroutine clear_optstring - - !####################################################################### - - elemental subroutine finalize_table_entry(te) - - ! Dummy argument - type(table_entry_t), intent(inout) :: te - ! Local variable - type(table_entry_t), pointer :: temp + hash_fact = tbl_gen_hash_key(ind_fact) + hash = ieor(hash, (ichar(string(index:index)) * hash_fact)) + end do + + hash_key = iand(hash, this%table_size - 1) + 1 + if ((hash_key < 1) .or. (hash_key > this%table_size)) then + if (present(errmsg)) then + write(errmsg, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & + hash_key, ' out of bounds, [1, ', this%table_size, ']' + else + write(6, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & + hash_key, ' out of bounds, [1, ', this%table_size, ']' + stop 1 + end if + end if + + end function hash_table_key_hash + + !####################################################################### + + function hash_table_table_value(this, key, errmsg) result(tbl_val) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Return the the key value of + ! + ! If the object is not found, return NULL + ! + !----------------------------------------------------------------------- + ! + ! Dummy Arguments: + ! + class(ccpp_hash_table_t) :: this + character(len=*), intent(in) :: key + character(len=*), optional, intent(out) :: errmsg + class(ccpp_hashable_t), pointer :: tbl_val + ! + ! Local. + ! + integer :: hash_key + type(table_entry_t), pointer :: next_ptr + character(len=*), parameter :: subname = 'HASH_TABLE_TABLE_INDEX' + + call clear_optstring(errmsg) + nullify(tbl_val) + hash_key = this%key_hash(key, errmsg=errmsg) + if (have_error(errmsg)) then + errmsg = trim(errmsg) // ', called from ' // subname + else if (associated(this%table(hash_key)%entry_value)) then + if (this%table(hash_key)%entry_value%key() == trim(key)) then + tbl_val => this%table(hash_key)%entry_value + else + next_ptr => this%table(hash_key)%next + do + if (associated(next_ptr)) then + if (associated(next_ptr%entry_value)) then + if (next_ptr%entry_value%key() == trim(key)) then + tbl_val => next_ptr%entry_value + exit + end if + end if + next_ptr => next_ptr%next + else + exit + end if + end do + end if + end if - if (associated(te%entry_value)) then - nullify(te%entry_value) ! We may not own the memory - temp => te%next - nullify(te%next) - if (associated(temp)) then - deallocate(temp) - nullify(temp) - end if + if ((.not.associated(tbl_val)) .and. present(errmsg)) then + if (.not.have_error(errmsg)) then ! Still need to test for empty + write(errmsg, *) subname, ": No entry for '", trim(key), "'" + end if + end if + + end function hash_table_table_value + + !####################################################################### + + subroutine hash_table_add_hash_key(this, newval, errmsg) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add to this hash table using its key + ! Its key must not be an empty string + ! It is an error to try to add a key more than once + ! + ! + !----------------------------------------------------------------------- + + ! Dummy arguments: + class(ccpp_hash_table_t) :: this + class(ccpp_hashable_t), target :: newval + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: hash_ind + integer :: ovflw_len + character(len=:), allocatable :: newkey + type(table_entry_t), pointer :: next_ptr + type(table_entry_t), pointer :: new_entry + character(len=*), parameter :: subname = 'HASH_TABLE_ADD_HASH_KEY' + + call clear_optstring(errmsg) + nullify(new_entry) + newkey = newval%key() + hash_ind = this%key_hash(newkey, errmsg=errmsg) + ! Check for this entry + if (have_error(errmsg)) then + errmsg = trim(errmsg) // ', called from ' // subname + else if (associated(this%table_value(newkey))) then + if (present(errmsg)) then + write(errmsg, *) subname, " ERROR: key, '", newkey, & + "' already in table" + end if + else + if (associated(this%table(hash_ind)%entry_value)) then + ! We have a collision, make a new entry + allocate(new_entry) + new_entry%entry_value => newval + ! Now, find a spot + if (associated(this%table(hash_ind)%next)) then + ovflw_len = 1 + next_ptr => this%table(hash_ind)%next + do + if (associated(next_ptr%next)) then + ovflw_len = ovflw_len + 1 + next_ptr => next_ptr%next + else + exit + end if + end do + ovflw_len = ovflw_len + 1 + next_ptr%next => new_entry + else + this%num_key_collisions = this%num_key_collisions + 1 + this%table(hash_ind)%next => new_entry + ovflw_len = 1 + end if + nullify(new_entry) + this%max_collision = max(this%max_collision, ovflw_len) + else + this%table(hash_ind)%entry_value => newval end if + this%num_keys = this%num_keys + 1 + end if - end subroutine finalize_table_entry + end subroutine hash_table_add_hash_key - !####################################################################### + !####################################################################### - logical function hash_table_is_initialized(this) - ! Return .true. iff is an initialized hash table + integer function hash_table_num_values(this) result(numval) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Return the number of populated table values + ! + !----------------------------------------------------------------------- - ! Dummy argument - class(ccpp_hash_table_t) :: this + ! Dummy argument: + class(ccpp_hash_table_t) :: this - hash_table_is_initialized = allocated(this%table) + numval = this%num_keys - end function hash_table_is_initialized + end function hash_table_num_values - !####################################################################### + !####################################################################### - subroutine hash_table_initialize_table(this, tbl_size, key_off) - ! Initialize this table. + subroutine hash_table_clear_table(this) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Deallocate the hash table and all of its entries + ! + !----------------------------------------------------------------------- - ! Dummy arguments - class(ccpp_hash_table_t) :: this - integer, intent(in) :: tbl_size ! new table size - integer, optional, intent(in) :: key_off ! key offset + ! Dummy argument: + class(ccpp_hash_table_t) :: this - ! Clear this table so it can be initialized + ! Clear all the table entries + if (this%is_initialized()) then if (allocated(this%table)) then - deallocate(this%table) - end if - this%num_keys = 0 - this%num_key_collisions = 0 - this%max_collision = 0 - ! Avoid too-large tables - this%table_size = ishft(1, MIN(tbl_size, bit_size(1) - 2)) - allocate(this%table(this%table_size)) - if (present(key_off)) then - this%key_offset = key_off + ! This should deallocate the entire chain of entries + deallocate(this%table) end if - end subroutine hash_table_initialize_table - - !####################################################################### - - integer function hash_table_key_hash(this, string, errmsg) result(hash_key) - ! - !----------------------------------------------------------------------- - ! - ! Purpose: Generate a hash key on the interval [0 .. tbl_hash_pri_sz-1] - ! given a character string. - ! - ! Algorithm is a variant of perl's internal hashing function. - ! - !----------------------------------------------------------------------- - ! - ! - ! Dummy Arguments: - ! - class(ccpp_hash_table_t) :: this - character(len=*), intent(in) :: string - character(len=*), optional, intent(out) :: errmsg - character(len=*), parameter :: subname = 'HASH_TABLE_KEY_HASH' - ! - ! Local. - ! - integer :: hash - integer :: index - integer :: ind_fact - integer :: hash_fact - - hash = this%key_offset - ind_fact = 0 - do index = 1, len_trim(string) - ind_fact = ind_fact + 1 - if (ind_fact > tbl_max_idx) then - ind_fact = 1 - end if - hash_fact = tbl_gen_hash_key(ind_fact) - hash = ieor(hash, (ichar(string(index:index)) * hash_fact)) - end do - - hash_key = iand(hash, this%table_size - 1) + 1 - if ((hash_key < 1) .or. (hash_key > this%table_size)) then - if (present(errmsg)) then - write(errmsg, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & - hash_key, ' out of bounds, [1, ', this%table_size, ']' - else - write(6, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & - hash_key, ' out of bounds, [1, ', this%table_size, ']' - STOP 1 - end if + end if + this%table_size = -1 + this%num_keys = 0 + this%num_key_collisions = 0 + this%max_collision = 0 + + end subroutine hash_table_clear_table + + !####################################################################### + ! + ! Hash iterator methods + ! + !####################################################################### + + subroutine hash_iterator_initialize(this, hash_table) + ! Initialize a hash_table iterator to the first value in the hash table + ! Note that the table_entry pointer is only used for the "next" field + ! in the hash table (entry itself is not a pointer). + + ! Dummy arguments + class(ccpp_hash_iterator_t) :: this + class(ccpp_hash_table_t), target :: hash_table + + this%hash_table => hash_table + this%index = 0 + nullify(this%table_entry) + do + this%index = this%index + 1 + if (associated(hash_table%table(this%index)%entry_value)) then + exit + else if (this%index > hash_table%table_size) then + this%index = 0 end if + end do + end subroutine hash_iterator_initialize - end function hash_table_key_hash - - !####################################################################### - - function hash_table_table_value(this, key, errmsg) result(tbl_val) - ! - !----------------------------------------------------------------------- - ! - ! Purpose: Return the the key value of - ! - ! If the object is not found, return NULL - ! - !----------------------------------------------------------------------- - ! - ! Dummy Arguments: - ! - class(ccpp_hash_table_t) :: this - character(len=*), intent(in) :: key - character(len=*), optional, intent(out) :: errmsg - class(ccpp_hashable_t), pointer :: tbl_val - ! - ! Local. - ! - integer :: hash_key - type(table_entry_t), pointer :: next_ptr - character(len=*), parameter :: subname = 'HASH_TABLE_TABLE_INDEX' - - call clear_optstring(errmsg) - nullify(tbl_val) - hash_key = this%key_hash(key, errmsg=errmsg) - if (have_error(errmsg)) then - errmsg = trim(errmsg)//', called from '//subname - else if (associated(this%table(hash_key)%entry_value)) then - if (this%table(hash_key)%entry_value%key() == trim(key)) then - tbl_val => this%table(hash_key)%entry_value - else - next_ptr => this%table(hash_key)%next - do - if (associated(next_ptr)) then - if (associated(next_ptr%entry_value)) then - if (next_ptr%entry_value%key() == trim(key)) then - tbl_val => next_ptr%entry_value - exit - end if - end if - next_ptr => next_ptr%next - else - exit - end if - end do - end if - end if + !####################################################################### - if ((.not. associated(tbl_val)) .and. present(errmsg)) then - if (.not. have_error(errmsg)) then ! Still need to test for empty - write(errmsg, *) subname, ": No entry for '", trim(key), "'" - end if - end if + function hash_iterator_key(this) result(key) + ! Return the key for this hash iterator entry - end function hash_table_table_value - - !####################################################################### - - subroutine hash_table_add_hash_key(this, newval, errmsg) - ! - !----------------------------------------------------------------------- - ! - ! Purpose: Add to this hash table using its key - ! Its key must not be an empty string - ! It is an error to try to add a key more than once - ! - ! - !----------------------------------------------------------------------- - - ! Dummy arguments: - class(ccpp_hash_table_t) :: this - class(ccpp_hashable_t), target :: newval - character(len=*), optional, intent(out) :: errmsg - ! Local variables - integer :: hash_ind - integer :: ovflw_len - character(len=:), allocatable :: newkey - type(table_entry_t), pointer :: next_ptr - type(table_entry_t), pointer :: new_entry - character(len=*), parameter :: subname = 'HASH_TABLE_ADD_HASH_KEY' - - call clear_optstring(errmsg) - nullify(new_entry) - newkey = newval%key() - hash_ind = this%key_hash(newkey, errmsg=errmsg) - ! Check for this entry - if (have_error(errmsg)) then - errmsg = trim(errmsg)//', called from '//subname - else if (associated(this%table_value(newkey))) then - if (present(errmsg)) then - write(errmsg, *) subname, " ERROR: key, '", newkey, & - "' already in table" - end if + ! Dummy arguments + class(ccpp_hash_iterator_t) :: this + character(len=:), allocatable :: key + + if (this%valid()) then + if (associated(this%table_entry)) then + key = this%table_entry%entry_value%key() else - if (associated(this%table(hash_ind)%entry_value)) then - ! We have a collision, make a new entry - allocate(new_entry) - new_entry%entry_value => newval - ! Now, find a spot - if (associated(this%table(hash_ind)%next)) then - ovflw_len = 1 - next_ptr => this%table(hash_ind)%next - do - if (associated(next_ptr%next)) then - ovflw_len = ovflw_len + 1 - next_ptr => next_ptr%next - else - exit - end if - end do - ovflw_len = ovflw_len + 1 - next_ptr%next => new_entry - else - this%num_key_collisions = this%num_key_collisions + 1 - this%table(hash_ind)%next => new_entry - ovflw_len = 1 - end if - nullify(new_entry) - this%max_collision = MAX(this%max_collision, ovflw_len) - else - this%table(hash_ind)%entry_value => newval - end if - this%num_keys = this%num_keys + 1 + key = this%hash_table%table(this%index)%entry_value%key() end if + else + key = '' + end if - end subroutine hash_table_add_hash_key - - !####################################################################### - - integer function hash_table_num_values(this) result(numval) - ! - !----------------------------------------------------------------------- - ! - ! Purpose: Return the number of populated table values - ! - !----------------------------------------------------------------------- - - ! Dummy argument: - class(ccpp_hash_table_t) :: this + end function hash_iterator_key - numval = this%num_keys + !####################################################################### - end function hash_table_num_values + subroutine hash_iterator_next_entry(this) + ! Set the iterator to the next valid hash table value - !####################################################################### + ! Dummy argument + class(ccpp_hash_iterator_t) :: this + ! Local variable + logical :: has_table_entry + logical :: has_table_next - subroutine hash_table_clear_table(this) - ! - !----------------------------------------------------------------------- - ! - ! Purpose: Deallocate the hash table and all of its entries - ! - !----------------------------------------------------------------------- - - ! Dummy argument: - class(ccpp_hash_table_t) :: this - - ! Clear all the table entries - if (this%is_initialized()) then - if (allocated(this%table)) then - ! This should deallocate the entire chain of entries - deallocate(this%table) - end if - end if - this%table_size = -1 - this%num_keys = 0 - this%num_key_collisions = 0 - this%max_collision = 0 - - end subroutine hash_table_clear_table - - !####################################################################### - ! - ! Hash iterator methods - ! - !####################################################################### - - subroutine hash_iterator_initialize(this, hash_table) - ! Initialize a hash_table iterator to the first value in the hash table - ! Note that the table_entry pointer is only used for the "next" field - ! in the hash table (entry itself is not a pointer). - - ! Dummy arguments - class(ccpp_hash_iterator_t) :: this - class(ccpp_hash_table_t), target :: hash_table - - this%hash_table => hash_table - this%index = 0 - nullify(this%table_entry) - do - this%index = this%index + 1 - if (associated(hash_table%table(this%index)%entry_value)) then - exit - else if (this%index > hash_table%table_size) then - this%index = 0 - end if - end do - end subroutine hash_iterator_initialize - - !####################################################################### - - function hash_iterator_key(this) result(key) - ! Return the key for this hash iterator entry - - ! Dummy arguments - class(ccpp_hash_iterator_t) :: this - character(len=:), allocatable :: key - - if (this%valid()) then - if (associated(this%table_entry)) then - key = this%table_entry%entry_value%key() - else - key = this%hash_table%table(this%index)%entry_value%key() - end if + if (this%index > 0) then + ! We have initialized this table, so look for next entry + has_table_entry = associated(this%table_entry) + if (has_table_entry) then + has_table_next = associated(this%table_entry%next) else - key = '' + has_table_next = .false. end if - - end function hash_iterator_key - - !####################################################################### - - subroutine hash_iterator_next_entry(this) - ! Set the iterator to the next valid hash table value - - ! Dummy argument - class(ccpp_hash_iterator_t) :: this - ! Local variable - logical :: has_table_entry - logical :: has_table_next - - if (this%index > 0) then - ! We have initialized this table, so look for next entry - has_table_entry = associated(this%table_entry) - if (has_table_entry) then - has_table_next = associated(this%table_entry%next) - else - has_table_next = .false. - end if - if (has_table_next) then - this%table_entry => this%table_entry%next - else if ((.not. has_table_entry) .and. & - associated(this%hash_table%table(this%index)%next)) then - this%table_entry => this%hash_table%table(this%index)%next - else - do - if (this%index >= this%hash_table%table_size) then - this%index = 0 - nullify(this%table_entry) - exit - else - this%index = this%index + 1 - nullify(this%table_entry) - ASSOCIATE(t_entry => this%hash_table%table(this%index)) - if (associated(t_entry%entry_value)) then - exit - end if - END ASSOCIATE - end if - end do - end if + if (has_table_next) then + this%table_entry => this%table_entry%next + else if ((.not.has_table_entry) .and. & + associated(this%hash_table%table(this%index)%next)) then + this%table_entry => this%hash_table%table(this%index)%next else - ! This is an invalid iterator state - nullify(this%table_entry) + do + if (this%index >= this%hash_table%table_size) then + this%index = 0 + nullify(this%table_entry) + exit + else + this%index = this%index + 1 + nullify(this%table_entry) + associate(t_entry => this%hash_table%table(this%index)) + if (associated(t_entry%entry_value)) then + exit + end if + end associate + end if + end do end if + else + ! This is an invalid iterator state + nullify(this%table_entry) + end if - end subroutine hash_iterator_next_entry + end subroutine hash_iterator_next_entry - !####################################################################### + !####################################################################### - logical function hash_iterator_is_valid(this) result(valid) - ! Return .true. iff this iterator is in a valid (active entry) state + logical function hash_iterator_is_valid(this) result(valid) + ! Return .true. iff this iterator is in a valid (active entry) state - ! Dummy arguments - class(ccpp_hash_iterator_t) :: this + ! Dummy arguments + class(ccpp_hash_iterator_t) :: this - valid = .false. - if ( (this%index > 0) .and. & - (this%index <= this%hash_table%table_size)) then - valid = .true. - end if + valid = .false. + if ((this%index > 0) .and. & + (this%index <= this%hash_table%table_size)) then + valid = .true. + end if - end function hash_iterator_is_valid + end function hash_iterator_is_valid - !####################################################################### + !####################################################################### - function hash_iterator_value(this) result(val) - ! Return the value or this hash iterator entry + function hash_iterator_value(this) result(val) + ! Return the value or this hash iterator entry - ! Dummy arguments - class(ccpp_hash_iterator_t) :: this - class(ccpp_hashable_t), pointer :: val + ! Dummy arguments + class(ccpp_hash_iterator_t) :: this + class(ccpp_hashable_t), pointer :: val - if (this%valid()) then - if (associated(this%table_entry)) then - val => this%table_entry%entry_value - else - val => this%hash_table%table(this%index)%entry_value - end if + if (this%valid()) then + if (associated(this%table_entry)) then + val => this%table_entry%entry_value else - nullify(val) + val => this%hash_table%table(this%index)%entry_value end if + else + nullify(val) + end if - end function hash_iterator_value + end function hash_iterator_value end module ccpp_hash_table diff --git a/src/ccpp_hashable.F90 b/src/ccpp_hashable.F90 index fc2399b7..26664f10 100644 --- a/src/ccpp_hashable.F90 +++ b/src/ccpp_hashable.F90 @@ -1,98 +1,98 @@ module ccpp_hashable - implicit none - private - - ! Public interfaces - public :: new_hashable_char - public :: new_hashable_int - - type, abstract, public :: ccpp_hashable_t - ! The hashable type is a base type that contains a hash key. - contains - procedure(ccpp_hashable_get_key), deferred :: key - end type ccpp_hashable_t - - type, public, extends(ccpp_hashable_t) :: ccpp_hashable_char_t - character(len=:), private, allocatable :: name - contains - procedure :: key => ccpp_hashable_char_get_key - end type ccpp_hashable_char_t - - type, public, extends(ccpp_hashable_t) :: ccpp_hashable_int_t - integer, private :: value - contains - procedure :: key => ccpp_hashable_int_get_key - procedure :: val => ccpp_hashable_int_get_val - end type ccpp_hashable_int_t - - ! Abstract interface for key procedure of ccpp_hashable_t class - abstract interface - function ccpp_hashable_get_key(hashable) - import :: ccpp_hashable_t - class(ccpp_hashable_t), intent(in) :: hashable - character(len=:), allocatable :: ccpp_hashable_get_key - end function ccpp_hashable_get_key - end interface - -CONTAINS - - !####################################################################### - - subroutine new_hashable_char(name_in, new_obj) - character(len=*), intent(in) :: name_in - type(ccpp_hashable_char_t), pointer :: new_obj - - if (associated(new_obj)) then - deallocate(new_obj) - end if - allocate(new_obj) - new_obj%name = name_in - end subroutine new_hashable_char - - !####################################################################### - - function ccpp_hashable_char_get_key(hashable) - ! Return the hashable char class key (name) - class(ccpp_hashable_char_t), intent(in) :: hashable - character(len=:), allocatable :: ccpp_hashable_char_get_key - - ccpp_hashable_char_get_key = hashable%name - end function ccpp_hashable_char_get_key - - !####################################################################### - - subroutine new_hashable_int(val_in, new_obj) - integer, intent(in) :: val_in - type(ccpp_hashable_int_t), pointer :: new_obj - - if (associated(new_obj)) then - deallocate(new_obj) - end if - allocate(new_obj) - new_obj%value = val_in - end subroutine new_hashable_int - - !####################################################################### - - function ccpp_hashable_int_get_key(hashable) - ! Return the hashable int class key (value ==> string) - class(ccpp_hashable_int_t), intent(in) :: hashable - character(len=:), allocatable :: ccpp_hashable_int_get_key - - character(len=32) :: key_str - - write(key_str, '(i0)') hashable%val() - ccpp_hashable_int_get_key = trim(key_str) - end function ccpp_hashable_int_get_key - - !####################################################################### - - integer function ccpp_hashable_int_get_val(hashable) - ! Return the hashable int class value - class(ccpp_hashable_int_t), intent(in) :: hashable - - ccpp_hashable_int_get_val = hashable%value - end function ccpp_hashable_int_get_val + implicit none + private + + ! Public interfaces + public :: new_hashable_char + public :: new_hashable_int + + type, abstract, public :: ccpp_hashable_t + ! The hashable type is a base type that contains a hash key. + contains + procedure(ccpp_hashable_get_key), deferred :: key + end type ccpp_hashable_t + + type, public, extends(ccpp_hashable_t) :: ccpp_hashable_char_t + character(len=:), private, allocatable :: name + contains + procedure :: key => ccpp_hashable_char_get_key + end type ccpp_hashable_char_t + + type, public, extends(ccpp_hashable_t) :: ccpp_hashable_int_t + integer, private :: value + contains + procedure :: key => ccpp_hashable_int_get_key + procedure :: val => ccpp_hashable_int_get_val + end type ccpp_hashable_int_t + + ! Abstract interface for key procedure of ccpp_hashable_t class + abstract interface + function ccpp_hashable_get_key(hashable) + import :: ccpp_hashable_t + class(ccpp_hashable_t), intent(in) :: hashable + character(len=:), allocatable :: ccpp_hashable_get_key + end function ccpp_hashable_get_key + end interface + +contains + + !####################################################################### + + subroutine new_hashable_char(name_in, new_obj) + character(len=*), intent(in) :: name_in + type(ccpp_hashable_char_t), pointer :: new_obj + + if (associated(new_obj)) then + deallocate(new_obj) + end if + allocate(new_obj) + new_obj%name = name_in + end subroutine new_hashable_char + + !####################################################################### + + function ccpp_hashable_char_get_key(hashable) + ! Return the hashable char class key (name) + class(ccpp_hashable_char_t), intent(in) :: hashable + character(len=:), allocatable :: ccpp_hashable_char_get_key + + ccpp_hashable_char_get_key = hashable%name + end function ccpp_hashable_char_get_key + + !####################################################################### + + subroutine new_hashable_int(val_in, new_obj) + integer, intent(in) :: val_in + type(ccpp_hashable_int_t), pointer :: new_obj + + if (associated(new_obj)) then + deallocate(new_obj) + end if + allocate(new_obj) + new_obj%value = val_in + end subroutine new_hashable_int + + !####################################################################### + + function ccpp_hashable_int_get_key(hashable) + ! Return the hashable int class key (value ==> string) + class(ccpp_hashable_int_t), intent(in) :: hashable + character(len=:), allocatable :: ccpp_hashable_int_get_key + + character(len=32) :: key_str + + write(key_str, '(i0)') hashable%val() + ccpp_hashable_int_get_key = trim(key_str) + end function ccpp_hashable_int_get_key + + !####################################################################### + + integer function ccpp_hashable_int_get_val(hashable) + ! Return the hashable int class value + class(ccpp_hashable_int_t), intent(in) :: hashable + + ccpp_hashable_int_get_val = hashable%value + end function ccpp_hashable_int_get_val end module ccpp_hashable diff --git a/src/ccpp_scheme_utils.F90 b/src/ccpp_scheme_utils.F90 index bb3a4d41..f6920e85 100644 --- a/src/ccpp_scheme_utils.F90 +++ b/src/ccpp_scheme_utils.F90 @@ -1,121 +1,121 @@ module ccpp_scheme_utils - ! Module of utilities available to CCPP schemes + ! Module of utilities available to CCPP schemes - use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, int_unassigned + use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, int_unassigned - implicit none - private + implicit none + private - !! Public interfaces - public :: ccpp_initialize_constituent_ptr ! Used by framework to initialize - public :: ccpp_constituent_index ! Lookup index constituent by name - public :: ccpp_constituent_indices ! Lookup indices of consitutents by name + !! Public interfaces + public :: ccpp_initialize_constituent_ptr ! Used by framework to initialize + public :: ccpp_constituent_index ! Lookup index constituent by name + public :: ccpp_constituent_indices ! Lookup indices of consitutents by name - !! Private module variables & interfaces + !! Private module variables & interfaces - ! initialized set to .true. once hash table pointer is initialized - logical :: initialized = .false. - type(ccpp_model_constituents_t), pointer :: constituent_obj => NULL() + ! initialized set to .true. once hash table pointer is initialized + logical :: initialized = .false. + type(ccpp_model_constituents_t), pointer :: constituent_obj => null() - private :: check_initialization - private :: status_ok + private :: check_initialization + private :: status_ok contains - subroutine check_initialization(caller, errcode, errmsg) - ! Dummy arguments - character(len=*), intent(in) :: caller - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - if (initialized) then - if (present(errcode)) then - errcode = 0 - end if - if (present(errmsg)) then - errmsg = '' - end if - else - if (present(errcode)) then - errcode = 1 - end if - if (present(errmsg)) then - errmsg = trim(caller)//' FAILED, module not initialized' - end if - end if - end subroutine check_initialization - - logical function status_ok(errcode) - ! Dummy argument - integer, optional, intent(in) :: errcode + subroutine check_initialization(caller, errcode, errmsg) + ! Dummy arguments + character(len=*), intent(in) :: caller + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + if (initialized) then if (present(errcode)) then - status_ok = (errcode == 0) .and. initialized - else - status_ok = initialized + errcode = 0 end if - - end function status_ok - - subroutine ccpp_initialize_constituent_ptr(const_obj) - ! Dummy arguments - type(ccpp_model_constituents_t), pointer, intent(in) :: const_obj - - if (.not. initialized) then - constituent_obj => const_obj - initialized = .true. + if (present(errmsg)) then + errmsg = '' end if - end subroutine ccpp_initialize_constituent_ptr - - subroutine ccpp_constituent_index(standard_name, const_index, errcode, errmsg) - ! Dummy arguments - character(len=*), intent(in) :: standard_name - integer, intent(out) :: const_index - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - ! Local variable - character(len=*), parameter :: subname = 'ccpp_constituent_index' - - call check_initialization(caller=subname, errcode=errcode, errmsg=errmsg) - if (status_ok(errcode)) then - call constituent_obj%const_index(const_index, standard_name, & - errcode, errmsg) - else - const_index = int_unassigned + else + if (present(errcode)) then + errcode = 1 end if - end subroutine ccpp_constituent_index - - subroutine ccpp_constituent_indices(standard_names, const_inds, errcode, errmsg) - ! Dummy arguments - character(len=*), intent(in) :: standard_names(:) - integer, intent(out) :: const_inds(:) - integer, optional, intent(out) :: errcode - character(len=*), optional, intent(out) :: errmsg - - ! Local variables - integer :: indx - character(len=*), parameter :: subname = 'ccpp_constituent_indices' - - const_inds = int_unassigned - call check_initialization(caller=subname, errcode=errcode, errmsg=errmsg) - if (status_ok(errcode)) then - if (size(const_inds) < size(standard_names)) then - errcode = 1 - write(errmsg, '(3a)') subname, ": const_inds array too small. ", & - "Must be greater than or equal to the size of standard_names" - else - do indx = 1, size(standard_names) - ! For each std name in , find the const. index - call constituent_obj%const_index(const_inds(indx), & - standard_names(indx), errcode, errmsg) - if (errcode /= 0) then - exit - end if - end do - end if + if (present(errmsg)) then + errmsg = trim(caller) // ' FAILED, module not initialized' + end if + end if + end subroutine check_initialization + + logical function status_ok(errcode) + ! Dummy argument + integer, optional, intent(in) :: errcode + + if (present(errcode)) then + status_ok = (errcode == 0) .and. initialized + else + status_ok = initialized + end if + + end function status_ok + + subroutine ccpp_initialize_constituent_ptr(const_obj) + ! Dummy arguments + type(ccpp_model_constituents_t), pointer, intent(in) :: const_obj + + if (.not.initialized) then + constituent_obj => const_obj + initialized = .true. + end if + end subroutine ccpp_initialize_constituent_ptr + + subroutine ccpp_constituent_index(standard_name, const_index, errcode, errmsg) + ! Dummy arguments + character(len=*), intent(in) :: standard_name + integer, intent(out) :: const_index + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + ! Local variable + character(len=*), parameter :: subname = 'ccpp_constituent_index' + + call check_initialization(caller=subname, errcode=errcode, errmsg=errmsg) + if (status_ok(errcode)) then + call constituent_obj%const_index(const_index, standard_name, & + errcode, errmsg) + else + const_index = int_unassigned + end if + end subroutine ccpp_constituent_index + + subroutine ccpp_constituent_indices(standard_names, const_inds, errcode, errmsg) + ! Dummy arguments + character(len=*), intent(in) :: standard_names(:) + integer, intent(out) :: const_inds(:) + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + ! Local variables + integer :: indx + character(len=*), parameter :: subname = 'ccpp_constituent_indices' + + const_inds = int_unassigned + call check_initialization(caller=subname, errcode=errcode, errmsg=errmsg) + if (status_ok(errcode)) then + if (size(const_inds) < size(standard_names)) then + errcode = 1 + write(errmsg, '(3a)') subname, ": const_inds array too small. ", & + "Must be greater than or equal to the size of standard_names" + else + do indx = 1, size(standard_names) + ! For each std name in , find the const. index + call constituent_obj%const_index(const_inds(indx), & + standard_names(indx), errcode, errmsg) + if (errcode /= 0) then + exit + end if + end do end if - end subroutine ccpp_constituent_indices + end if + end subroutine ccpp_constituent_indices end module ccpp_scheme_utils diff --git a/src/ccpp_types.F90 b/src/ccpp_types.F90 index 7370add4..ccdb71f8 100644 --- a/src/ccpp_types.F90 +++ b/src/ccpp_types.F90 @@ -19,74 +19,74 @@ ! module ccpp_types - use mpi_f08, only: MPI_Comm + use mpi_f08, only: mpi_comm !! \section arg_table_ccpp_types !! \htmlinclude ccpp_types.html !! - implicit none + implicit none - private - public :: ccpp_t, one - public :: MPI_Comm + private + public :: ccpp_t, one + public :: mpi_comm - !> @var Definition of constant one - integer, parameter :: one = 1 + !> @var Definition of constant one + integer, parameter :: one = 1 - !> @var The default loop counter indicating outside of a subcycle loop - integer, parameter :: CCPP_DEFAULT_LOOP_CNT = -999 - integer, parameter :: CCPP_DEFAULT_LOOP_MAX = -999 + !> @var The default loop counter indicating outside of a subcycle loop + integer, parameter :: ccpp_default_loop_cnt = -999 + integer, parameter :: ccpp_default_loop_max = -999 - !> @var The default values for block, chunk and thread numbers indicating invalid data - integer, parameter :: CCPP_DEFAULT_BLOCK_NUMBER = -999 - integer, parameter :: CCPP_DEFAULT_CHUNK_NUMBER = -999 - integer, parameter :: CCPP_DEFAULT_THREAD_NUMBER = -999 + !> @var The default values for block, chunk and thread numbers indicating invalid data + integer, parameter :: ccpp_default_block_number = -999 + integer, parameter :: ccpp_default_chunk_number = -999 + integer, parameter :: ccpp_default_thread_number = -999 - !> @var The default maximum number of threads for CCPP - integer, parameter :: CCPP_DEFAULT_THREAD_COUNT = -999 + !> @var The default maximum number of threads for CCPP + integer, parameter :: ccpp_default_thread_count = -999 !! \section arg_table_ccpp_t !! \htmlinclude ccpp_t.html !! - !> - !! @brief CCPP physics type. - !! - !! Generic type that contains all components to run the CCPP. - !! - !! - Array of fields to all the data needing to go - !! the physics drivers. - !! - The suite definitions in a ccpp_suite_t type. - ! - type :: ccpp_t - ! CCPP-internal variables for physics schemes - integer :: errflg = 0 - character(len=512) :: errmsg = '' - integer :: loop_cnt = CCPP_DEFAULT_LOOP_CNT - integer :: loop_max = CCPP_DEFAULT_LOOP_MAX - integer :: blk_no = CCPP_DEFAULT_BLOCK_NUMBER - integer :: chunk_no = CCPP_DEFAULT_CHUNK_NUMBER - integer :: thrd_no = CCPP_DEFAULT_THREAD_NUMBER - integer :: thrd_cnt = CCPP_DEFAULT_THREAD_COUNT - integer :: ccpp_instance = 1 + !> + !! @brief CCPP physics type. + !! + !! Generic type that contains all components to run the CCPP. + !! + !! - Array of fields to all the data needing to go + !! the physics drivers. + !! - The suite definitions in a ccpp_suite_t type. + ! + type :: ccpp_t + ! CCPP-internal variables for physics schemes + integer :: errflg = 0 + character(len=512) :: errmsg = '' + integer :: loop_cnt = ccpp_default_loop_cnt + integer :: loop_max = ccpp_default_loop_max + integer :: blk_no = ccpp_default_block_number + integer :: chunk_no = ccpp_default_chunk_number + integer :: thrd_no = ccpp_default_thread_number + integer :: thrd_cnt = ccpp_default_thread_count + integer :: ccpp_instance = 1 contains - procedure :: initialized => ccpp_t_initialized + procedure :: initialized => ccpp_t_initialized - end type ccpp_t + end type ccpp_t contains - function ccpp_t_initialized(ccpp_d) result(initialized) - implicit none - ! - class(ccpp_t) :: ccpp_d - logical :: initialized - ! - initialized = ccpp_d%thrd_no /= CCPP_DEFAULT_THREAD_NUMBER .or. & - ccpp_d%blk_no /= CCPP_DEFAULT_BLOCK_NUMBER .or. & - ccpp_d%chunk_no /= CCPP_DEFAULT_CHUNK_NUMBER - end function ccpp_t_initialized + function ccpp_t_initialized(ccpp_d) result(initialized) + implicit none + ! + class(ccpp_t) :: ccpp_d + logical :: initialized + ! + initialized = ccpp_d%thrd_no /= ccpp_default_thread_number .or. & + ccpp_d%blk_no /= ccpp_default_block_number .or. & + ccpp_d%chunk_no /= ccpp_default_chunk_number + end function ccpp_t_initialized end module ccpp_types