From 81a7a994aafa2d33f058e03adc5b1e60d1a398e4 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 11 Apr 2023 12:03:14 -0400 Subject: [PATCH 01/93] Move from FLAP to fArgParse --- CHANGELOG.md | 4 ++ Tests/ExtDataDriver.F90 | 4 +- Tests/pfio_MAPL_demo.F90 | 53 +++++++++++++------------- tutorial/driver_app/Example_Driver.F90 | 5 +-- 4 files changed, 34 insertions(+), 32 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 867b3d4faf4b..70999e116482 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,12 +15,16 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Updated programs using FLAP for command line parsing to use fArgParse instead + ### Fixed ### Removed ### Deprecated +- Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 + ## [2.37.0] - 2023-04-03 ### Added diff --git a/Tests/ExtDataDriver.F90 b/Tests/ExtDataDriver.F90 index 71dc735c0102..ea7a061d0f0f 100644 --- a/Tests/ExtDataDriver.F90 +++ b/Tests/ExtDataDriver.F90 @@ -16,9 +16,9 @@ program ExtData_Driver character(len=*), parameter :: Iam="ExtData_Driver" type(ExtDataDriver) :: Driver type (MAPL_CapOptions) :: cap_options - type (MAPL_FlapCLI) :: cli + type (MAPL_FargparseCLI) :: cli - cli = MAPL_FlapCLI(description='extdata driver',authors='gmao') + cli = MAPL_FargparseCLI() cap_options=MAPL_CapOptions(cli) driver = ExtDataDriver('ExtDataApp',Root_SetServices,cap_options=cap_options,_RC) diff --git a/Tests/pfio_MAPL_demo.F90 b/Tests/pfio_MAPL_demo.F90 index a601e7ee8f58..b8c84f4534f9 100755 --- a/Tests/pfio_MAPL_demo.F90 +++ b/Tests/pfio_MAPL_demo.F90 @@ -10,7 +10,7 @@ ! !#### Usage: ! -! If we reserve 2 haswell nodes (28 cores in each), want to run the model on 28 cores +! If we reserve 2 haswell nodes (28 cores in each), want to run the model on 28 cores ! and use 1 MultiGroup with 5 backend processes, then the execution command is: !``` ! mpiexec -np 56 pfio_MAPL_demo.x --npes_model 28 --oserver_type multigroup --nodes_output_server 1 --npes_backend_pernode 5 @@ -38,7 +38,7 @@ program main integer, parameter :: num_dims = 2 ! number of dimension to decompose ! PFIO specific variables - type(MAPL_FlapCLI) :: cli + type(MAPL_FargparseCLI) :: cli type(MAPL_CapOptions) :: cap_options type(ServerManager) :: ioserver_manager type(SplitCommunicator) :: split_comm @@ -85,8 +85,7 @@ program main !------------------------------------------------------------------------------ ! Read and parse the command line, and set parameters - cli = MAPL_FlapCLI(description = 'GEOS AGCM', & - authors = 'GMAO') + cli = MAPL_FargparseCLI() cap_options = MAPL_CapOptions(cli) ! Initialize MPI if MPI_Init has not been called @@ -123,22 +122,22 @@ program main ! ---> Perform domain decomposition for the model !------------------------------------------------ call perform_domain_deposition() - + ! Allocate model variables !------------------------- ALLOCATE(local_tracer(i1:i2, j1:j2)) ALLOCATE(local_temp(i1:i2, j1:j2, k1:k2)) - + ! if there are multiple oserver, split it into large and small pool call o_clients%split_server_pools() - + call create_file_metada() - + !--------------------------------------------- ! ---> Model time stepping and writing outputs !--------------------------------------------- call run_model() - + deallocate(local_temp) deallocate(local_tracer) deallocate(points_per_procX) @@ -157,11 +156,11 @@ program main call ioserver_manager%finalize() call MPI_finalize(ierror) - + !------------------------------------------------------------------------------ CONTAINS !------------------------------------------------------------------------------ -!> +!> ! `create_member_subcommunicator` -- Create a subcommunicator ! integer function create_member_subcommunicator(comm, n_members, npes_member, rc) result(subcommunicator) @@ -183,7 +182,7 @@ integer function create_member_subcommunicator(comm, n_members, npes_member, rc) end function create_member_subcommunicator !------------------------------------------------------------------------------ -!> +!> ! `initialize_mpi` -- Initialized MPI is MPI_Init has not been called yet. ! subroutine initialize_mpi(comm) @@ -204,7 +203,7 @@ subroutine initialize_mpi(comm) end subroutine initialize_mpi !------------------------------------------------------------------------------ -!> +!> ! `initialize_ioserver` -- Initialize the IO Server using the command line options ! subroutine initialize_ioserver(comm) @@ -224,7 +223,7 @@ subroutine initialize_ioserver(comm) _VERIFY(status) end subroutine initialize_ioserver !------------------------------------------------------------------------------ -!> +!> ! `perform_domain_deposition` -- Perfom the domain decomposition ! subroutine perform_domain_deposition() @@ -267,7 +266,7 @@ subroutine perform_domain_deposition() print '(a7,i5,a5,4i5)', 'pe_id: ', pe_id, '-->', i1, i2, j1, j2 end subroutine perform_domain_deposition !------------------------------------------------------------------------------ -!> +!> ! `create_file_metada` -- Create the file metada using PFIO methods and the file collection identifier ! subroutine create_file_metada() @@ -348,7 +347,7 @@ subroutine create_file_metada() hist_id = o_clients%add_hist_collection(fmd) end subroutine create_file_metada !------------------------------------------------------------------------------ -!> +!> ! `run_model` -- Run the model and write out the data ! subroutine run_model() @@ -415,7 +414,7 @@ subroutine run_model() enddo end subroutine run_model !------------------------------------------------------------------------------ -!> +!> ! `add_fvar` -- PFIO utility routine to create a variable and set attributes ! subroutine add_fvar(cf, vname, vtype, dims, units, long_name ,rc) @@ -449,10 +448,10 @@ subroutine add_fvar(cf, vname, vtype, dims, units, long_name ,rc) _VERIFY(status) end subroutine add_fvar !------------------------------------------------------------------------------ -!> -! `decompose_dim` -- -! For a given number of grid points along a dimension and a number of -! available processors for that diemsion,, !! determine the number of +!> +! `decompose_dim` -- +! For a given number of grid points along a dimension and a number of +! available processors for that diemsion,, !! determine the number of ! grid points assigned to each processor. ! subroutine decompose_dim(dim_world, dim_array, num_procs ) @@ -472,7 +471,7 @@ subroutine decompose_dim(dim_world, dim_array, num_procs ) end subroutine decompose_dim !------------------------------------------------------------------------------ !> -! `decompose_proc` -- +! `decompose_proc` -- ! Given the total number of available processors and the number of dimensions, ! determine the number of processors along each dimension. ! @@ -491,10 +490,10 @@ subroutine decompose_proc(num_procs, proc_sizes) END DO end subroutine decompose_proc !------------------------------------------------------------------------------ -!> -! `mapping_domain` -- +!> +! `mapping_domain` -- ! Determime the indices of the local domain corners -! with respect to the global domain. +! with respect to the global domain. ! subroutine mapping_domain(map_proc, map_domainX, map_domainY, & points_per_procX, points_per_procY, NX, NY, & @@ -550,7 +549,7 @@ subroutine mapping_domain(map_proc, map_domainX, map_domainY, & enddo end subroutine mapping_domain !------------------------------------------------------------------------------ -!> +!> ! `set_tracer` -- Arbitrary set values for a field ! subroutine set_tracer(var) @@ -566,7 +565,7 @@ subroutine set_tracer(var) end subroutine set_tracer !------------------------------------------------------------------------------ -!> +!> ! `set_temperature` -- Arbitrary set values for the temperature field. ! subroutine set_temperature(var) diff --git a/tutorial/driver_app/Example_Driver.F90 b/tutorial/driver_app/Example_Driver.F90 index f489f358637f..f974d002a624 100644 --- a/tutorial/driver_app/Example_Driver.F90 +++ b/tutorial/driver_app/Example_Driver.F90 @@ -8,12 +8,11 @@ program Example_Driver implicit none type (MAPL_Cap) :: cap - type (MAPL_FlapCLI) :: cli + type (MAPL_FargparseCLI) :: cli type (MAPL_CapOptions) :: cap_options integer :: status - cli = MAPL_FlapCLI(description = 'GEOS AGCM', & - authors = 'GMAO') + cli = MAPL_FargparseCLI() cap_options = MAPL_CapOptions(cli) cap = MAPL_Cap('example', cap_options = cap_options) call cap%run(_RC) From 2ecdbb7d6c972d3e0d0f046df6a65d4172e135bf Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 26 Apr 2023 12:49:11 -0400 Subject: [PATCH 02/93] update to use hconfig to parse yaml --- gridcomps/ExtData2G/CMakeLists.txt | 2 - gridcomps/ExtData2G/ExtDataConfig.F90 | 180 ++++++++---------- gridcomps/ExtData2G/ExtDataDerived.F90 | 16 +- gridcomps/ExtData2G/ExtDataFileStream.F90 | 33 ++-- gridcomps/ExtData2G/ExtDataGridCompNG.F90 | 13 +- gridcomps/ExtData2G/ExtDataRule.F90 | 42 ++-- gridcomps/ExtData2G/ExtDataSample.F90 | 32 ++-- gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 | 14 -- .../ExtData2G/ExtDataYamlNodeWrapper.F90 | 11 -- 9 files changed, 146 insertions(+), 197 deletions(-) delete mode 100644 gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 delete mode 100644 gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 0088a84b77fd..286af145629d 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -20,8 +20,6 @@ set (srcs ExtData_IOBundleMod.F90 ExtData_IOBundleVectorMod.F90 ExtDataMasking.F90 - ExtDataYamlNodeStack.F90 - ExtDataYamlNodeWrapper.F90 ) diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index cc20edc46671..1b2710341b1a 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -17,8 +17,6 @@ module MAPL_ExtDataConfig use MAPL_ExtDataTimeSampleMap use MAPL_TimeStringConversion use MAPL_ExtDataMask - use MAPL_ExtDataYamlNodeStack - use MAPL_ExtDataYamlNodeWrapper implicit none private @@ -50,15 +48,12 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - type(Parser) :: p -#ifndef __GFORTRAN__ - class(YAML_Node), allocatable :: config -#else - integer :: my_stack -#endif - class(YAML_Node), pointer :: subcfg, ds_config, rule_config, derived_config, sample_config, subconfigs, rule_map - class(NodeIterator), allocatable :: iter - character(len=:), pointer :: key + type(ESMF_HConfig) :: input_config + type(ESMF_HConfig) :: temp_configs + type(ESMF_HConfig) :: hconfigIter,hconfigIterBegin,hconfigIterEnd + character(len=:), allocatable :: hconfig_key + type(ESMF_HConfig) :: single_sample,single_collection,single_export,rule_map,hconfig_val + character(len=:), allocatable :: new_key type(ExtDataFileStream) :: ds type(ExtDataDerived) :: derived @@ -66,119 +61,101 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ integer :: status type(ExtDataFileStream), pointer :: temp_ds - type(ExtDataTimeSample), pointer :: temp_ts type(ExtDataDerived), pointer :: temp_derived - character(len=:), pointer :: sub_file integer :: i,num_rules integer, allocatable :: sorted_rules(:) character(len=1) :: i_char logical :: file_found + logical :: is_right_type + character(len=:), allocatable :: sub_configs(:) _UNUSED_DUMMY(unusable) inquire(file=trim(config_file),exist=file_found) _ASSERT(file_found,"could not find: "//trim(config_file)) -#ifdef __GFORTRAN__ - stack_depth = stack_depth + 1 - _ASSERT(stack_depth <= MAX_FILE_DEPTH,"yaml config stack too small") - my_stack = stack_depth - associate(config => yaml_node_stack(my_stack)%a_yaml_node) -#endif - p = Parser('core') - config = p%load(config_file,rc=status) - if (status/=_SUCCESS) then - _FAIL("Error parsing "//trim(config_file)) - end if + input_config = ESMF_HConfigCreate(filename=trim(config_file),_RC) - if (config%has("subconfigs")) then - subconfigs => config%at("subconfigs") - _ASSERT(subconfigs%is_sequence(),'subconfigs is not a sequence') - do i=1,subconfigs%size() - sub_file => to_string(subconfigs%at(i)) - call new_ExtDataConfig_from_yaml(ext_config,sub_file,current_time,rc=status) - _VERIFY(status) - end do -#ifdef __GFORTRAN__ - deallocate(config) - config = p%load(config_file,rc=status) -#endif + if (ESMF_HConfigIsDefined(input_config,keyString="subconfigs")) then + is_right_type = ESMF_HConfigIsSequence(input_config,keyString='subconfigs',_RC) + _ASSERT(is_right_type,"subconfig list is not a sequence") + sub_configs = ESMF_HConfigAsStringSeq(input_config,ESMF_MAXPATHLEN,keyString='subconfigs',_RC) + do i=1,size(sub_configs) + call new_ExtDataConfig_from_yaml(ext_config,sub_configs(i),current_time,_RC) + enddo end if - - - if (config%has("Samplings")) then - sample_config => config%of("Samplings") - iter = sample_config%begin() - do while (iter /= sample_config%end()) - key => to_string(iter%first(),_RC) - temp_ts => ext_config%sample_map%at(key) - _ASSERT(.not.associated(temp_ts),"defined duplicate named sample key") - subcfg => iter%second() - ts = ExtDataTimeSample(subcfg,_RC) - _VERIFY(status) - call ext_config%sample_map%insert(trim(key),ts) - call iter%next() + + if (ESMF_HConfigIsDefined(input_config,keyString="Samplings")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Samplings",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + single_sample = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + ts = ExtDataTimeSample(single_sample,_RC) + call ext_config%sample_map%insert(trim(hconfig_key),ts) enddo end if - if (config%has("Collections")) then - ds_config => config%of("Collections") - iter = ds_config%begin() - do while (iter /= ds_config%end()) - key => to_string(iter%first(),_RC) - temp_ds => ext_config%file_stream_map%at(key) + if (ESMF_HConfigIsDefined(input_config,keyString="Collections")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Collections",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + temp_ds => ext_config%file_stream_map%at(hconfig_key) _ASSERT(.not.associated(temp_ds),"defined duplicate named collection") - subcfg => iter%second() - ds = ExtDataFileStream(subcfg,current_time,_RC) - call ext_config%file_stream_map%insert(trim(key),ds) - call iter%next() + single_collection = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + ds = ExtDataFileStream(single_collection,current_time,_RC) + call ext_config%file_stream_map%insert(trim(hconfig_key),ds) enddo end if - if (config%has("Exports")) then - rule_config => config%of("Exports") - iter = rule_config%begin() - do while (iter /= rule_config%end()) - key => to_string(iter%first(),_RC) - subcfg => iter%second() - if (subcfg%is_mapping()) then - call ext_config%add_new_rule(key,subcfg,_RC) - else if (subcfg%is_sequence()) then - sorted_rules = sort_rules_by_start(subcfg,_RC) - num_rules = subcfg%size() + if (ESMF_HConfigIsDefined(input_config,keyString="Exports")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Exports",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + hconfig_val = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + if (ESMF_HConfigIsMap(hconfig_val)) then + call ext_config%add_new_rule(hconfig_key,hconfig_val,_RC) + else if (ESMF_HConfigIsSequence(hconfig_val)) then + sorted_rules = sort_rules_by_start(hconfig_val,_RC) + num_rules = ESMF_HConfigGetSize(hconfig_val,_RC) do i=1,num_rules - rule_map => subcfg%of(sorted_rules(i)) + rule_map = ESMF_HConfigCreateAt(hconfig_val,index=sorted_rules(i),_RC) write(i_char,'(I1)')i - new_key = key//rule_sep//i_char + new_key = hconfig_key//rule_sep//i_char call ext_config%add_new_rule(new_key,rule_map,multi_rule=.true.,_RC) enddo - else - _FAIL("Exports must be sequence or map") + else + _FAIL("Unsupported type") end if - call iter%next() enddo end if - if (config%has("Derived")) then - derived_config => config%at("Derived") - iter = derived_config%begin() - do while (iter /= derived_config%end()) - call derived%set_defaults(rc=status) - _VERIFY(status) - key => to_string(iter%first(),_RC) - subcfg => iter%second() - derived = ExtDataDerived(subcfg,_RC) - temp_derived => ext_config%derived_map%at(trim(key)) + if (ESMF_HConfigIsDefined(input_config,keyString="Derived")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Derived",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + single_export = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + derived = ExtDataDerived(single_export,_RC) + temp_derived => ext_config%derived_map%at(trim(hconfig_key)) _ASSERT(.not.associated(temp_derived),"duplicated derived entry key") - call ext_config%derived_map%insert(trim(key),derived) - call iter%next() - enddo + call ext_config%derived_map%insert(trim(hconfig_key),derived) + end do end if - if (config%has("debug")) then - call config%get(ext_config%debug,"debug",rc=status) - _VERIFY(status) + if (ESMF_HConfigIsDefined(input_config,keyString="debug") )then + ext_config%debug = ESMF_HConfigAsI4(input_config,keyString="debug",_RC) end if #ifdef __GFORTRAN__ @@ -250,27 +227,28 @@ function get_time_range(this,item_name,rc) result(time_range) _RETURN(_SUCCESS) end function get_time_range - function sort_rules_by_start(yaml_sequence,rc) result(sorted_index) + function sort_rules_by_start(hconfig_sequence,rc) result(sorted_index) integer, allocatable :: sorted_index(:) - class(YAML_Node), intent(inout) :: yaml_sequence + type(ESMF_HConfig), intent(inout) :: hconfig_sequence integer, optional, intent(out) :: rc integer :: num_rules,i,j,i_temp,imin logical :: found_start - class(YAML_Node), pointer :: yaml_dict + type(ESMF_HConfig) :: hconfig_dict character(len=:), allocatable :: start_time type(ESMF_Time), allocatable :: start_times(:) type(ESMF_Time) :: temp_time + integer :: status - num_rules = yaml_sequence%size() + num_rules = ESMF_HConfigGetSize(hconfig_sequence,_RC) allocate(start_times(num_rules)) allocate(sorted_index(num_rules),source=[(i,i=1,num_rules)]) do i=1,num_rules - yaml_dict => yaml_sequence%of(i) - found_start = yaml_dict%has("starting") + hconfig_dict = ESMF_HConfigCreateAt(hconfig_sequence,index=i,_RC) + found_start = ESMF_HConfigIsDefined(hconfig_dict,keyString="starting") _ASSERT(found_start,"no start key in multirule export of extdata") - start_time = yaml_dict%of("starting") + start_time = ESMF_HConfigAsString(hconfig_dict,keyString="starting",_RC) start_times(i) = string_to_esmf_time(start_time) enddo @@ -344,7 +322,7 @@ end function get_item_type subroutine add_new_rule(this,key,export_rule,multi_rule,rc) class(ExtDataConfig), intent(inout) :: this character(len=*), intent(in) :: key - class(YAML_Node), intent(in) :: export_rule + type(ESMF_HConfig), intent(in) :: export_rule logical, optional, intent(in) :: multi_rule integer, intent(out), optional :: rc @@ -394,8 +372,6 @@ function get_extra_derived_items(this,primary_items,derived_items,rc) result(nee type(ExtDataDerived), pointer :: derived_item type(StringVector) :: variables_in_expression character(len=:), pointer :: sval,derived_name - character(len=:), allocatable :: base_name - type(ExtDataRule), pointer :: rule logical :: in_primary,found_rule integer :: i diff --git a/gridcomps/ExtData2G/ExtDataDerived.F90 b/gridcomps/ExtData2G/ExtDataDerived.F90 index f036898ce6b0..af926e9117b0 100644 --- a/gridcomps/ExtData2G/ExtDataDerived.F90 +++ b/gridcomps/ExtData2G/ExtDataDerived.F90 @@ -27,7 +27,7 @@ module MAPL_ExtDataDerived contains function new_ExtDataDerived(config,unusable,rc) result(rule) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -39,17 +39,17 @@ function new_ExtDataDerived(config,unusable,rc) result(rule) if (allocated(tempc)) deallocate(tempc) - is_present = config%has("function") + is_present = ESMF_HConfigIsDefined(config,keyString="function",_RC) _ASSERT(is_present,"no expression found in derived entry") - call config%get(tempc,"function",rc=status) - _VERIFY(status) - rule%expression=tempc + if (is_present) then + tempc = ESMF_HConfigAsString(config,keyString="function",_RC) + rule%expression=tempc + end if if (allocated(tempc)) deallocate(tempc) - is_present = config%has("sample") + is_present = ESMF_HConfigIsDefined(config,keyString="sample",_RC) if (is_present) then - call config%get(tempc,"sample",rc=status) - _VERIFY(status) + tempc = ESMF_HConfigAsString(config,keyString="sample",_RC) rule%sample_key=tempc end if diff --git a/gridcomps/ExtData2G/ExtDataFileStream.F90 b/gridcomps/ExtData2G/ExtDataFileStream.F90 index fa4ce0ec7810..efb53581b65c 100644 --- a/gridcomps/ExtData2G/ExtDataFileStream.F90 +++ b/gridcomps/ExtData2G/ExtDataFileStream.F90 @@ -15,7 +15,7 @@ module MAPL_ExtDataFileStream private type, public :: ExtDataFileStream - character(:), allocatable :: file_template + character(len=:), allocatable :: file_template type(ESMF_TimeInterval) :: frequency type(ESMF_Time) :: reff_time integer :: collection_id @@ -31,7 +31,7 @@ module MAPL_ExtDataFileStream contains function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) - class(Yaml_node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config type(ESMF_Time), intent(in) :: current_time class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -46,20 +46,17 @@ function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) _UNUSED_DUMMY(unusable) - if (config%is_scalar()) then - - else if (config%is_mapping()) then - is_present = config%has("template") - _ASSERT(is_present,"no file template in the collection") - if (is_present) then - call config%get(data_set%file_template,"template",rc=status) - _VERIFY(status) - file_frequency = get_string_with_default(config,"freq") - file_reff_time = get_string_with_default(config,"ref_time") - range_str = get_string_with_default(config,"valid_range") - end if - end if + is_present = ESMF_HConfigIsDefined(config,keyString="template",_RC) + _ASSERT(is_present,"no file template in the collection") + + if (is_present) then + data_set%file_template = ESMF_HConfigAsString(config,keyString="template",_RC) + file_frequency = get_string_with_default(config,"freq") + file_reff_time = get_string_with_default(config,"ref_time") + range_str = get_string_with_default(config,"valid_range") + end if + if (file_frequency /= '') then data_set%frequency = string_to_esmf_timeinterval(file_frequency) else @@ -142,12 +139,12 @@ function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) contains function get_string_with_default(config,selector) result(string) - class(Yaml_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config character(len=*), intent(In) :: selector character(len=:), allocatable :: string - if (config%has(selector)) then - string=config%of(selector) + if (ESMF_HConfigIsDefined(config,keyString=selector)) then + string = ESMF_HConfigAsString(config,keyString=selector,_RC) else string='' end if diff --git a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 index 999ae4cf84a3..3272e8a1092c 100644 --- a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 +++ b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 @@ -1768,19 +1768,14 @@ function am_i_running(yaml_file,rc) result(am_running) character(len=*), intent(in) :: yaml_file integer, intent(out), optional :: rc - type(Parser) :: p - class(YAML_Node), allocatable :: config + type(ESMF_HConfig), allocatable :: config integer :: status am_running=.true. - p = Parser('core') - config = p%load(yaml_file,rc=status) - if (status/=_SUCCESS) then - _FAIL("Error parsing: "//trim(yaml_file)) - end if - if (config%has("USE_EXTDATA")) then - am_running = config%of("USE_EXTDATA") + config = ESMF_HConfigCreate(filename = trim(yaml_file),_RC) + if (ESMF_HConfigIsDefined(config,keyString="USE_EXTDATA")) then + am_running = ESMF_HConfigAsLogical(config,keyString="USE_EXTDATA",_RC) end if _RETURN(_SUCCESS) diff --git a/gridcomps/ExtData2G/ExtDataRule.F90 b/gridcomps/ExtData2G/ExtDataRule.F90 index 82af19610df5..d579c5656a3f 100644 --- a/gridcomps/ExtData2G/ExtDataRule.F90 +++ b/gridcomps/ExtData2G/ExtDataRule.F90 @@ -34,7 +34,7 @@ module MAPL_ExtDataRule contains function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(rule) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config character(len=*), intent(in) :: key type(ExtDataTimeSampleMap) :: sample_map class(KeywordEnforcer), optional, intent(in) :: unusable @@ -44,7 +44,7 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru type(ExtDataRule) :: rule logical :: collection_present, variable_present integer :: status - class(YAML_Node), pointer ::config1 + type(ESMF_HConfig) ::config1 character(len=:), allocatable :: tempc type(ExtDataTimeSample) :: ts logical :: usable_multi_rule @@ -57,60 +57,60 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru end if if (allocated(tempc)) deallocate(tempc) - collection_present = config%has("collection") + collection_present = ESMF_HConfigIsDefined(config,keyString="collection") _ASSERT(collection_present,"no collection present in ExtData export") - rule%collection = config%of("collection") + rule%collection = ESMF_HConfigAsString(config,keyString="collection",_RC) if (allocated(tempc)) deallocate(tempc) - variable_present = config%has("variable") + variable_present = ESMF_HConfigIsDefined(config,keyString="variable") if (index(rule%collection,"/dev/null")==0) then _ASSERT(variable_present,"no variable present in ExtData export") end if if (variable_present) then - tempc = config%of("variable") + tempc = ESMF_HConfigAsString(config,keyString="variable",_RC) rule%file_var=tempc else rule%file_var='null' end if - if (config%has("sample")) then - config1=>config%at("sample") - if (config1%is_mapping()) then + if (ESMF_HConfigIsDefined(config,keyString="sample")) then + + config1 = ESMF_HConfigCreateAt(config,keyString="sample",_RC) + if (ESMF_HConfigIsMap(config1)) then ts = ExtDataTimeSample(config1,_RC) call sample_map%insert(trim(key)//"_sample",ts) rule%sample_key=trim(key)//"_sample" - else if (config1%is_string()) then - rule%sample_key=config1 else - _FAIL("sample entry unsupported") + rule%sample_key=ESMF_HConfigAsString(config1,_RC) end if else rule%sample_key = "" end if if (allocated(rule%linear_trans)) deallocate(rule%linear_trans) - if (config%has("linear_transformation")) then - call config%get(rule%linear_trans,"linear_transformation") + if (ESMF_HConfigIsDefined(config,keyString="linear_transformation")) then + allocate(rule%linear_trans(2)) + rule%linear_trans = ESMF_HConfigAsR4Seq(config,keyString="linear_transformation",_RC) else allocate(rule%linear_trans,source=[0.0,0.0]) end if if (allocated(tempc)) deallocate(tempc) - if (config%has("regrid")) then - tempc = config%of("regrid") + if (ESMF_HConfigIsDefined(config,keyString="regrid")) then + tempc = ESMF_HConfigAsString(config,keyString="regrid",_RC) rule%regrid_method=tempc else rule%regrid_method="BILINEAR" end if - if (config%has("starting")) then - tempc = config%of("starting") + if (ESMF_HConfigIsDefined(config,keyString="starting")) then + tempc = ESMF_HConfigAsString(config,keyString="starting",_RC) rule%start_time = tempc end if - if (config%has("fail_on_missing_file")) then - rule%fail_on_missing_file = config%of("fail_on_missing_file") - end if + if (ESMF_HConfigIsDefined(config,keyString="fail_on_missing_file")) then + rule%fail_on_missing_file = ESMF_HConfigAsLogical(config,keyString="fail_on_missing_file",_RC) + end if rule%multi_rule=usable_multi_rule diff --git a/gridcomps/ExtData2G/ExtDataSample.F90 b/gridcomps/ExtData2G/ExtDataSample.F90 index 5e19e22fc9ff..ebdbfc534cb9 100644 --- a/gridcomps/ExtData2G/ExtDataSample.F90 +++ b/gridcomps/ExtData2G/ExtDataSample.F90 @@ -27,7 +27,7 @@ module MAPL_ExtDataTimeSample contains function new_ExtDataTimeSample(config,unusable,rc) result(TimeSample) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -39,28 +39,36 @@ function new_ExtDataTimeSample(config,unusable,rc) result(TimeSample) call TimeSample%set_defaults() - if (config%has("extrapolation")) TimeSample%extrap_outside=config%of("extrapolation") + if (ESMF_HConfigIsDefined(config,keyString="extrapolation")) then + TimeSample%extrap_outside=ESMF_HConfigAsString(config,keyString="extrapolation",_RC) + end if - if (config%has("time_interpolation")) then - TimeSample%time_interpolation = config%of("time_interpolation") + if (ESMF_HConfigIsDefined(config,keyString="time_interpolation")) then + TimeSample%time_interpolation = ESMF_HConfigAsLogical(config,keyString="time_interpolation",_RC) else TimeSample%time_interpolation = .true. end if - if (config%has("exact")) then - TimeSample%exact = config%of("exact") + + if (ESMF_HConfigIsDefined(config,keyString="exact")) then + TimeSample%exact = ESMF_HConfigAsLogical(config,keyString="exact",_RC) else TimeSample%exact = .false. end if - if (config%has("update_reference_time")) TimeSample%refresh_time=config%of("update_reference_time") + if (ESMF_HConfigIsDefined(config,keyString="update_reference_time")) then + TimeSample%refresh_time = ESMF_HConfigAsString(config,keyString="update_reference_time",_RC) + end if - if (config%has("update_reference_time")) TimeSample%refresh_frequency=config%of("update_frequency") + if (ESMF_HConfigIsDefined(config,keyString="update_frequency")) then + TimeSample%refresh_frequency = ESMF_HConfigAsString(config,keyString="update_frequency",_RC) + end if - if (config%has("update_offset")) TimeSample%refresh_offset=config%of("update_offset") + if (ESMF_HConfigIsDefined(config,keyString="update_offset")) then + TimeSample%refresh_offset = ESMF_HConfigAsString(config,keyString="update_offset",_RC) + end if - if (config%has("source_time")) then - call config%get(source_str,"source_time",rc=status) - _VERIFY(status) + if (ESMF_HConfigIsDefined(config,keyString="source_time")) then + source_str = ESMF_HConfigAsString(config,keyString="source_time",_RC) if (allocated(TimeSample%source_time)) deallocate(TimeSample%source_time) idx = index(source_str,'/') _ASSERT(idx/=0,'invalid specification of source_time') diff --git a/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 b/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 deleted file mode 100644 index 8a46e80933f2..000000000000 --- a/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 +++ /dev/null @@ -1,14 +0,0 @@ -module MAPL_ExtDataYamlNodeStack - use yaFyaml - use MAPL_ExtDataYamlNodeWrapper - implicit none - - public :: max_file_depth - public :: stack_depth - public :: yaml_node_stack - - integer, save :: stack_depth = 0 - integer, parameter :: MAX_FILE_DEPTH = 20 - type(YamlNodeWrapper), save :: yaml_node_stack(MAX_FILE_DEPTH) - -end module MAPL_ExtDataYamlNodeStack diff --git a/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 b/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 deleted file mode 100644 index 4e88b19047f1..000000000000 --- a/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module MAPL_ExtDataYamlNodeWrapper - use yaFyaml - implicit none - - public YamlNodeWrapper - - type :: YamlNodeWrapper - class(YAML_Node), allocatable :: a_yaml_node - end type - -end module MAPL_ExtDataYamlNodeWrapper From 54ff9ea7d0ad9d1b94492c23a140b34ed367d6c9 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 15 May 2023 13:41:29 -0400 Subject: [PATCH 03/93] Fixes #2133. Allow setting of some ESMF settings without CLI --- CHANGELOG.md | 3 +++ gridcomps/Cap/MAPL_Cap.F90 | 13 +++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1cb5231ef910..c1fdca7e6964 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added ability to use an `ESMF.rc` file to pass in pre-`ESMF_Initialize` options to ESMF (see [ESMF Docs](https://earthsystemmodeling.org/docs/release/latest/ESMF_refdoc/node4.html#SECTION04024000000000000000) for allowed flags. + - NOTE: File *must* be called `ESMF.rc` + ### Changed ### Fixed diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 438107c6a54a..4e0783e8f684 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -273,13 +273,22 @@ subroutine run_model(this, comm, unusable, rc) integer(kind=INT64) :: start_tick, stop_tick, tick_rate integer :: status class(Logger), pointer :: lgr + logical :: file_exists _UNUSED_DUMMY(unusable) call start_timer() - call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, rc=status) - _VERIFY(status) + ! Look for a file called "ESMF.rc" + inquire(file='ESMF.rc', exist=file_exists) + + ! If the file exists, we pass it into ESMF_Initialize, else, we + ! use the one from the command line arguments + if (file_exists) then + call ESMF_Initialize (configFileName='ESMF.rc', mpiCommunicator=comm, _RC) + else + call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, _RC) + end if ! Note per ESMF this is a temporary routine as eventually MOAB will ! be the only mesh generator. But until then, this allows us to From 8ed92a9e851fe8474d6d3afee3a12892da5a5169 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 23 May 2023 14:35:00 -0400 Subject: [PATCH 04/93] fixes #2147 --- CHANGELOG.md | 2 + base/FieldUtilities.F90 | 152 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 154 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 893e91901585..d657865dc03b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added field utilities to set a field or field in a state to a constant real number + ### Changed ### Fixed diff --git a/base/FieldUtilities.F90 b/base/FieldUtilities.F90 index 6a83c6e6dd8a..2778481b644b 100644 --- a/base/FieldUtilities.F90 +++ b/base/FieldUtilities.F90 @@ -9,6 +9,18 @@ module MAPL_FieldUtilities private public is_field_undef +public set_field_to_constant +public set_state_field_to_constant + +interface set_state_field_to_constant + module procedure set_state_field_to_constant_r4 + module procedure set_state_field_to_constant_r8 +end interface + +interface set_field_to_constant + module procedure set_field_to_constant_r4 + module procedure set_field_to_constant_r8 +end interface contains @@ -49,5 +61,145 @@ function is_field_undef(field,rc) result(field_is_undef) end function +subroutine set_state_field_to_constant_r8(state,field_name,constant_val,rc) + type(ESMF_State), intent(inout) :: state + character(len=*), intent(in) :: field_name + real(kind=ESMF_KIND_R8), intent(in) :: constant_val + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + integer :: status + + call ESMF_StateGet(state,field_name,field,_RC) + call set_field_to_constant(field,constant_val,_RC) + + _RETURN(_SUCCESS) +end subroutine set_state_field_to_constant_r8 + +subroutine set_state_field_to_constant_r4(state,field_name,constant_val,rc) + type(ESMF_State), intent(inout) :: state + character(len=*), intent(in) :: field_name + real(kind=ESMF_KIND_R4), intent(in) :: constant_val + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + integer :: status + + call ESMF_StateGet(state,field_name,field,_RC) + call set_field_to_constant(field,constant_val,_RC) + + _RETURN(_SUCCESS) +end subroutine set_state_field_to_constant_r4 + +subroutine set_field_to_constant_r4(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_r4), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: x_r4_1d(:),x_r4_2d(:,:),x_r4_3d(:,:,:),x_r4_4d(:,:,:,:),x_r4_5d(:,:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_r8_1d(:),x_r8_2d(:,:),x_r8_3d(:,:,:),x_r8_4d(:,:,:,:),x_r8_5d(:,:,:,:,:) + integer :: status, rank + + call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + if (rank == 1) then + call ESMF_FieldGet(field,farrayptr=x_r4_1d,_RC) + x_r4_1d = constant_val + else if (rank == 2) then + call ESMF_FieldGet(field,farrayptr=x_r4_2d,_RC) + x_r4_2d = constant_val + else if (rank == 3) then + call ESMF_FieldGet(field,farrayptr=x_r4_3d,_RC) + x_r4_3d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) + x_r4_4d = constant_val + else if (rank == 5) then + call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) + x_r4_5d = constant_val + else + _FAIL('unsupported rank') + end if + else if (type_kind == ESMF_TYPEKIND_R8) then + if (rank == 1) then + call ESMF_FieldGet(field,farrayptr=x_r8_1d,_RC) + x_r8_1d = constant_val + else if (rank == 2) then + call ESMF_FieldGet(field,farrayptr=x_r8_2d,_RC) + x_r8_2d = constant_val + else if (rank == 3) then + call ESMF_FieldGet(field,farrayptr=x_r8_3d,_RC) + x_r8_3d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r8_4d,_RC) + x_r8_4d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r8_5d,_RC) + x_r8_5d = constant_val + else + _FAIL('unsupported rank') + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine set_field_to_constant_r4 + +subroutine set_field_to_constant_r8(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_R8), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: x_r4_1d(:),x_r4_2d(:,:),x_r4_3d(:,:,:),x_r4_4d(:,:,:,:),x_r4_5d(:,:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_r8_1d(:),x_r8_2d(:,:),x_r8_3d(:,:,:),x_r8_4d(:,:,:,:),x_r8_5d(:,:,:,:,:) + integer :: status, rank + + call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + if (rank == 1) then + call ESMF_FieldGet(field,farrayptr=x_r4_1d,_RC) + x_r4_1d = constant_val + else if (rank == 2) then + call ESMF_FieldGet(field,farrayptr=x_r4_2d,_RC) + x_r4_2d = constant_val + else if (rank == 3) then + call ESMF_FieldGet(field,farrayptr=x_r4_3d,_RC) + x_r4_3d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) + x_r4_4d = constant_val + else if (rank == 5) then + call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) + x_r4_5d = constant_val + else + _FAIL('unsupported rank') + end if + else if (type_kind == ESMF_TYPEKIND_R8) then + if (rank == 1) then + call ESMF_FieldGet(field,farrayptr=x_r8_1d,_RC) + x_r8_1d = constant_val + else if (rank == 2) then + call ESMF_FieldGet(field,farrayptr=x_r8_2d,_RC) + x_r8_2d = constant_val + else if (rank == 3) then + call ESMF_FieldGet(field,farrayptr=x_r8_3d,_RC) + x_r8_3d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r8_4d,_RC) + x_r8_4d = constant_val + else if (rank == 4) then + call ESMF_FieldGet(field,farrayptr=x_r8_5d,_RC) + x_r8_5d = constant_val + else + _FAIL('unsupported rank') + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) + end subroutine set_field_to_constant_r8 + end module From 80abc4fd4838e8721f1f11700ba161bab884a25c Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 25 May 2023 13:41:03 -0400 Subject: [PATCH 05/93] lots o changes --- MAPL/CMakeLists.txt | 2 +- MAPL/MAPL.F90 | 1 + Tests/ExtDataRoot_GridComp.F90 | 16 +- base/Base.F90 | 1 - base/CMakeLists.txt | 1 - base/FieldUtilities.F90 | 205 --------------------- geom/CMakeLists.txt | 5 +- geom/FieldBLAS.F90 | 302 +------------------------------ geom/FieldPointerUtilities.F90 | 317 +++++++++++++++++++++++++++++++++ geom/FieldUtilities.F90 | 95 ++++++++++ geom/geom.F90 | 5 + geom/tests/Test_FieldBLAS.pf | 1 + pfio/CMakeLists.txt | 6 +- 13 files changed, 436 insertions(+), 521 deletions(-) delete mode 100644 base/FieldUtilities.F90 create mode 100644 geom/FieldPointerUtilities.F90 create mode 100644 geom/FieldUtilities.F90 create mode 100644 geom/geom.F90 diff --git a/MAPL/CMakeLists.txt b/MAPL/CMakeLists.txt index f49b1d486a46..052c4bc45f82 100644 --- a/MAPL/CMakeLists.txt +++ b/MAPL/CMakeLists.txt @@ -3,7 +3,7 @@ esma_set_this() esma_add_library (${this} SRCS MAPL.F90 - DEPENDENCIES MAPL.base MAPL.generic MAPL.pfio MAPL_cfio_r4 MAPL.gridcomps MAPL.orbit MAPL.griddedio ${EXTDATA_TARGET} + DEPENDENCIES MAPL.base MAPL.generic MAPL.pfio MAPL_cfio_r4 MAPL.gridcomps MAPL.orbit MAPL.griddedio MAPL.geom ${EXTDATA_TARGET} esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran $<$:FLAP::FLAP> TYPE ${MAPL_LIBRARY_TYPE} diff --git a/MAPL/MAPL.F90 b/MAPL/MAPL.F90 index 4636b37f5b38..87e83c64b8dc 100644 --- a/MAPL/MAPL.F90 +++ b/MAPL/MAPL.F90 @@ -15,6 +15,7 @@ module MAPL use MAPL_OpenMP_Support, only : MAPL_find_bounds => find_bounds use MAPL_OpenMP_Support, only : MAPL_Interval => Interval use MAPL_Profiler, initialize_profiler =>initialize, finalize_profiler =>finalize + use MAPL_Geom implicit none end module MAPL diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 838ecece3430..d014cb509cc1 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -353,7 +353,7 @@ function evaluate_time(this,currTime,rc) result(dt) class(timeVar), intent(in) :: this type(ESMF_Time), intent(inout) :: currTime integer, optional, intent(out) :: rc - real(REAL64) :: dt + real(kind=ESMF_KIND_R8) :: dt integer :: status @@ -482,6 +482,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) type(ESMF_State) :: pstate character(len=:), pointer :: fexpr integer :: i1,in,j1,jn,ldims(3),i,j + real(kind=ESMF_KIND_R8) :: doy,time_delta call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) call MAPL_Grid_Interior(grid,i1,in,j1,jn) @@ -490,9 +491,6 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) _VERIFY(status) call ESMF_StateGet(outState,itemNameList=outNameList,_RC) - call MAPL_GetPointer(inState,exPtr2,'time',_RC) - exPtr2=synth%tFunc%evaluate_time(Time,_RC) - call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) do j = 1,ldims(2) do i=1,ldims(1) @@ -505,15 +503,17 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) exPtr2(i,j)=j1+j-1 enddo enddo - call MAPL_GetPointer(inState,exPtr2,'doy',_RC) - exPtr2 = compute_doy(time,_RC) call ESMF_StateGet(inState,'time',farray(1),_RC) + time_delta = synth%tFunc%evaluate_time(Time,_RC) + call FieldSet(farray(1), time_delta,_RC) call ESMF_StateGet(inState,'lons',farray(2),_RC) call ESMF_StateGet(inState,'lats',farray(3),_RC) call ESMF_StateGet(inState,'i_index',farray(4),_RC) call ESMF_StateGet(inState,'j_index',farray(5),_RC) call ESMF_StateGet(inState,'doy',farray(6),_RC) + doy = compute_doy(time,_RC) + call FieldSet(farray(6), doy,_RC) pstate = ESMF_StateCreate(_RC) call ESMF_StateAdd(pstate,farray,_RC) @@ -556,8 +556,8 @@ subroutine CompareState(State1,State2,tol,rc) call ESMF_StateGet(State2,trim(nameList(i)),field2,_RC) call ESMF_FieldGet(field1,rank=rank1,_RC) call ESMF_FieldGet(field2,rank=rank2,_RC) - all_undef1 = is_field_undef(field1,_RC) - all_undef2 = is_field_undef(field2,_RC) + all_undef1 = FieldIsConstant(field1,MAPL_UNDEF,_RC) + all_undef2 = FieldIsConstant(field2,MAPL_UNDEF,_RC) if (all_undef1 .or. all_undef2) then exit end if diff --git a/base/Base.F90 b/base/Base.F90 index 5413bcafbbae..32929296150d 100644 --- a/base/Base.F90 +++ b/base/Base.F90 @@ -51,7 +51,6 @@ module MAPLBase_Mod use MAPL_ServerManager use MAPL_FileMetadataUtilsMod use MAPL_VerticalDataMod - use MAPL_FieldUtilities use MAPL_SphericalGeometry logical, save, private :: mapl_is_initialized = .false. diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 8fa9fdb35e76..26694bb1b3c2 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -52,7 +52,6 @@ set (srcs Base/Base_Base.F90 Base/Base_Base_implementation.F90 TimeStringConversion.F90 MAPL_ISO8601_DateTime_ESMF.F90 - FieldUtilities.F90 MAPL_Resource.F90 MAPL_XYGridFactory.F90 MAPL_NetCDF.F90 diff --git a/base/FieldUtilities.F90 b/base/FieldUtilities.F90 deleted file mode 100644 index 2778481b644b..000000000000 --- a/base/FieldUtilities.F90 +++ /dev/null @@ -1,205 +0,0 @@ -#include "MAPL_Generic.h" - -module MAPL_FieldUtilities -use ESMF -use MAPL_BaseMod, only: MAPL_Undef -use MAPL_ErrorHandlingMod - -implicit none -private - -public is_field_undef -public set_field_to_constant -public set_state_field_to_constant - -interface set_state_field_to_constant - module procedure set_state_field_to_constant_r4 - module procedure set_state_field_to_constant_r8 -end interface - -interface set_field_to_constant - module procedure set_field_to_constant_r4 - module procedure set_field_to_constant_r8 -end interface - -contains - -function is_field_undef(field,rc) result(field_is_undef) - logical :: field_is_undef - type(ESMF_Field), intent(in) :: field - integer, optional, intent(out) :: rc - - integer :: status - - real(ESMF_KIND_R4), pointer :: ptr_1d_r4(:), ptr_2d_r4(:,:), ptr_3d_r4(:,:,:), ptr_4d_r4(:,:,:,:) - - integer :: rank - type(ESMF_TypeKind_Flag) :: typekind - - call ESMF_FieldGet(field,rank=rank,typekind=typekind,_RC) - - if (typekind == ESMF_TYPEKIND_R4) then - select case(rank) - case(1) - call ESMF_FieldGet(field,0,farrayPtr=ptr_1d_r4,_RC) - field_is_undef = all(ptr_1d_r4 == MAPL_UNDEF) - case(2) - call ESMF_FieldGet(field,0,farrayPtr=ptr_2d_r4,_RC) - field_is_undef = all(ptr_2d_r4 == MAPL_UNDEF) - case(3) - call ESMF_FieldGet(field,0,farrayPtr=ptr_3d_r4,_RC) - field_is_undef = all(ptr_3d_r4 == MAPL_UNDEF) - case(4) - call ESMF_FieldGet(field,0,farrayPtr=ptr_4d_r4,_RC) - field_is_undef = all(ptr_4d_r4 == MAPL_UNDEF) - end select - else - _FAIL("MAPL_UNDEF is single precision so you can not check if it is all undef for an R8") - end if - - _RETURN(_SUCCESS) - -end function - -subroutine set_state_field_to_constant_r8(state,field_name,constant_val,rc) - type(ESMF_State), intent(inout) :: state - character(len=*), intent(in) :: field_name - real(kind=ESMF_KIND_R8), intent(in) :: constant_val - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field - integer :: status - - call ESMF_StateGet(state,field_name,field,_RC) - call set_field_to_constant(field,constant_val,_RC) - - _RETURN(_SUCCESS) -end subroutine set_state_field_to_constant_r8 - -subroutine set_state_field_to_constant_r4(state,field_name,constant_val,rc) - type(ESMF_State), intent(inout) :: state - character(len=*), intent(in) :: field_name - real(kind=ESMF_KIND_R4), intent(in) :: constant_val - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field - integer :: status - - call ESMF_StateGet(state,field_name,field,_RC) - call set_field_to_constant(field,constant_val,_RC) - - _RETURN(_SUCCESS) -end subroutine set_state_field_to_constant_r4 - -subroutine set_field_to_constant_r4(field,constant_val,rc) - type(ESMF_Field), intent(inout) :: field - real(kind=ESMF_KIND_r4), intent(in) :: constant_val - integer, intent(out), optional :: rc - - type(ESMF_TYPEKIND_FLAG) :: type_kind - real(kind=ESMF_KIND_R4), pointer :: x_r4_1d(:),x_r4_2d(:,:),x_r4_3d(:,:,:),x_r4_4d(:,:,:,:),x_r4_5d(:,:,:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_r8_1d(:),x_r8_2d(:,:),x_r8_3d(:,:,:),x_r8_4d(:,:,:,:),x_r8_5d(:,:,:,:,:) - integer :: status, rank - - call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) - if (type_kind == ESMF_TYPEKIND_R4) then - if (rank == 1) then - call ESMF_FieldGet(field,farrayptr=x_r4_1d,_RC) - x_r4_1d = constant_val - else if (rank == 2) then - call ESMF_FieldGet(field,farrayptr=x_r4_2d,_RC) - x_r4_2d = constant_val - else if (rank == 3) then - call ESMF_FieldGet(field,farrayptr=x_r4_3d,_RC) - x_r4_3d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) - x_r4_4d = constant_val - else if (rank == 5) then - call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) - x_r4_5d = constant_val - else - _FAIL('unsupported rank') - end if - else if (type_kind == ESMF_TYPEKIND_R8) then - if (rank == 1) then - call ESMF_FieldGet(field,farrayptr=x_r8_1d,_RC) - x_r8_1d = constant_val - else if (rank == 2) then - call ESMF_FieldGet(field,farrayptr=x_r8_2d,_RC) - x_r8_2d = constant_val - else if (rank == 3) then - call ESMF_FieldGet(field,farrayptr=x_r8_3d,_RC) - x_r8_3d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r8_4d,_RC) - x_r8_4d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r8_5d,_RC) - x_r8_5d = constant_val - else - _FAIL('unsupported rank') - end if - else - _FAIL('unsupported typekind') - end if - _RETURN(ESMF_SUCCESS) -end subroutine set_field_to_constant_r4 - -subroutine set_field_to_constant_r8(field,constant_val,rc) - type(ESMF_Field), intent(inout) :: field - real(kind=ESMF_KIND_R8), intent(in) :: constant_val - integer, intent(out), optional :: rc - - type(ESMF_TYPEKIND_FLAG) :: type_kind - real(kind=ESMF_KIND_R4), pointer :: x_r4_1d(:),x_r4_2d(:,:),x_r4_3d(:,:,:),x_r4_4d(:,:,:,:),x_r4_5d(:,:,:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_r8_1d(:),x_r8_2d(:,:),x_r8_3d(:,:,:),x_r8_4d(:,:,:,:),x_r8_5d(:,:,:,:,:) - integer :: status, rank - - call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) - if (type_kind == ESMF_TYPEKIND_R4) then - if (rank == 1) then - call ESMF_FieldGet(field,farrayptr=x_r4_1d,_RC) - x_r4_1d = constant_val - else if (rank == 2) then - call ESMF_FieldGet(field,farrayptr=x_r4_2d,_RC) - x_r4_2d = constant_val - else if (rank == 3) then - call ESMF_FieldGet(field,farrayptr=x_r4_3d,_RC) - x_r4_3d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) - x_r4_4d = constant_val - else if (rank == 5) then - call ESMF_FieldGet(field,farrayptr=x_r4_4d,_RC) - x_r4_5d = constant_val - else - _FAIL('unsupported rank') - end if - else if (type_kind == ESMF_TYPEKIND_R8) then - if (rank == 1) then - call ESMF_FieldGet(field,farrayptr=x_r8_1d,_RC) - x_r8_1d = constant_val - else if (rank == 2) then - call ESMF_FieldGet(field,farrayptr=x_r8_2d,_RC) - x_r8_2d = constant_val - else if (rank == 3) then - call ESMF_FieldGet(field,farrayptr=x_r8_3d,_RC) - x_r8_3d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r8_4d,_RC) - x_r8_4d = constant_val - else if (rank == 4) then - call ESMF_FieldGet(field,farrayptr=x_r8_5d,_RC) - x_r8_5d = constant_val - else - _FAIL('unsupported rank') - end if - else - _FAIL('unsupported typekind') - end if - _RETURN(ESMF_SUCCESS) - end subroutine set_field_to_constant_r8 - -end module - diff --git a/geom/CMakeLists.txt b/geom/CMakeLists.txt index 742438b3b8cf..4fa2f2dd7036 100644 --- a/geom/CMakeLists.txt +++ b/geom/CMakeLists.txt @@ -11,7 +11,10 @@ esma_set_this (OVERRIDE MAPL.geom) # StateSupplement.F90 # ) set(srcs + geom.F90 FieldBLAS.F90 + FieldPointerUtilities.F90 + FieldUtilities.F90 ) # Workaround for strict NAG Fortran with ESMF implicit interface for private state. #set_property( SOURCE InnerMetaComponent.F90 OuterMetaComponent.F90 @@ -42,6 +45,6 @@ target_link_libraries (${this} PUBLIC esmf) if (PFUNIT_FOUND) # Turning off until test with GNU can be fixed - #add_subdirectory(tests EXCLUDE_FROM_ALL) + add_subdirectory(tests EXCLUDE_FROM_ALL) endif () diff --git a/geom/FieldBLAS.F90 b/geom/FieldBLAS.F90 index 4d87022773ae..ca5cccf72e10 100644 --- a/geom/FieldBLAS.F90 +++ b/geom/FieldBLAS.F90 @@ -3,6 +3,7 @@ module mapl3g_FieldBLAS use ESMF use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 implicit none @@ -42,9 +43,6 @@ module mapl3g_FieldBLAS public :: FieldSpread public :: FieldClone public :: FieldConvertPrec - public :: FieldGetLocalElementCount - public :: FieldGetLocalSize - public :: FieldGetCptr public :: FieldsAreConformable public :: FieldsAreSameTypeKind !wdb fixme temporary to test out this helper function @@ -74,23 +72,11 @@ module mapl3g_FieldBLAS procedure gemv_r8 end interface - interface FieldGetCptr - procedure get_cptr - end interface - interface FieldsAreConformable procedure are_conformable_scalar procedure are_conformable_array end interface - interface FieldGetLocalSize - procedure get_local_size - end interface FieldGetLocalSize - - interface FieldGetLocalElementCount - procedure get_local_element_count - end interface FieldGetLocalElementCount - interface FieldConvertPrec module procedure convert_prec end interface FieldConvertPrec @@ -103,13 +89,6 @@ module mapl3g_FieldBLAS module procedure clone end interface FieldClone - interface assign_fptr - module procedure assign_fptr_r4_rank1 - module procedure assign_fptr_r8_rank1 - module procedure assign_fptr_r4_rank2 - module procedure assign_fptr_r8_rank2 - end interface assign_fptr - interface FieldsAreSameTypeKind module procedure are_same_type_kind end interface FieldsAreSameTypeKind @@ -531,253 +510,6 @@ end subroutine verify_typekind_array ! _RETURN(_SUCCESS) ! end subroutine verify_typekind_rank1 - subroutine assign_fptr_r4_rank1(x, fptr, rc) - type(ESMF_Field), intent(inout) :: x - real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer(ESMF_KIND_I8), allocatable :: fp_shape(:) - integer(ESMF_KIND_I8) :: local_size - integer :: status - - local_size = FieldGetLocalSize(x, _RC) - fp_shape = [ local_size ] - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r4_rank1 - - subroutine assign_fptr_r8_rank1(x, fptr, rc) - type(ESMF_Field), intent(inout) :: x - real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer(ESMF_KIND_I8), allocatable :: fp_shape(:) - integer(ESMF_KIND_I8) :: local_size - integer :: status - - local_size = FieldGetLocalSize(x, _RC) - fp_shape = [ local_size ] - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r8_rank1 - - subroutine assign_fptr_r4_rank2(x, fp_shape, fptr, rc) - type(ESMF_Field), intent(inout) :: x - integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) - real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:,:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer :: status - - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r4_rank2 - - subroutine assign_fptr_r8_rank2(x, fp_shape, fptr, rc) - type(ESMF_Field), intent(inout) :: x - integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) - real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:,:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer :: status - - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r8_rank2 - - subroutine get_cptr(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - type(ESMF_TypeKind_Flag) :: tk_x - - call ESMF_FieldGet(x, typekind=tk_x, _RC) - - if (tk_x == ESMF_TYPEKIND_R4) then - call get_cptr_r4(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_R8) then - call get_cptr_r8(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_I4) then - call get_cptr_i4(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_I8) then - call get_cptr_i8(x, cptr, _RC) - else - _FAIL('Unsupported typekind in FieldGetCptr().') - end if - - _RETURN(_SUCCESS) - end subroutine get_cptr - - subroutine get_cptr_r4(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - real(kind=ESMF_KIND_R4), pointer :: x_1d(:) - real(kind=ESMF_KIND_R4), pointer :: x_2d(:,:) - real(kind=ESMF_KIND_R4), pointer :: x_3d(:,:,:) - real(kind=ESMF_KIND_R4), pointer :: x_4d(:,:,:,:) - real(kind=ESMF_KIND_R4), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_r4 - - subroutine get_cptr_r8(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - real(kind=ESMF_KIND_R8), pointer :: x_1d(:) - real(kind=ESMF_KIND_R8), pointer :: x_2d(:,:) - real(kind=ESMF_KIND_R8), pointer :: x_3d(:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_4d(:,:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_r8 - - subroutine get_cptr_i4(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - integer(kind=ESMF_KIND_I4), pointer :: x_1d(:) - integer(kind=ESMF_KIND_I4), pointer :: x_2d(:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_3d(:,:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_4d(:,:,:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_i4 - - subroutine get_cptr_i8(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - integer(kind=ESMF_KIND_I8), pointer :: x_1d(:) - integer(kind=ESMF_KIND_I8), pointer :: x_2d(:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_3d(:,:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_4d(:,:,:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_i8 - subroutine convert_prec(x, y, rc) type(ESMF_Field), intent(inout) :: x type(ESMF_Field), intent(inout) :: y @@ -963,36 +695,4 @@ logical function are_same_type_kind(x, y, rc) result(same_tk) _RETURN(_SUCCESS) end function are_same_type_kind - function get_local_element_count(x, rc) result(element_count) - type(ESMF_Field), intent(inout) :: x - integer, optional, intent(out) :: rc - integer, allocatable :: element_count(:) - - integer :: status - integer :: rank - -! element_count = [integer :: ] ! default - - call ESMF_FieldGet(x, rank=rank, _RC) - allocate(element_count(rank)) - call ESMF_FieldGet(x, localElementCount=element_count, _RC) - - _RETURN(_SUCCESS) - end function get_local_element_count - - function get_local_size(x, rc) result(sz) - integer(kind=ESMF_KIND_I8) :: sz - type(ESMF_Field), intent(inout) :: x - integer, optional, intent(out) :: rc - - integer :: status - integer, allocatable :: element_count(:) - - sz = 0 - element_count = FieldGetLocalElementCount(x, _RC) - sz = int(product(element_count), kind=ESMF_KIND_I8) - - _RETURN(_SUCCESS) - end function get_local_size - end module mapl3g_FieldBLAS diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 new file mode 100644 index 000000000000..c8e1ca487d55 --- /dev/null +++ b/geom/FieldPointerUtilities.F90 @@ -0,0 +1,317 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldPointerUtilities + use ESMF + use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 + implicit none + private + + public :: assign_fptr + public :: FieldGetLocalElementCount + public :: FieldGetLocalSize + public :: FieldGetCptr + + interface assign_fptr + module procedure assign_fptr_r4_rank1 + module procedure assign_fptr_r8_rank1 + module procedure assign_fptr_r4_rank2 + module procedure assign_fptr_r8_rank2 + end interface assign_fptr + + interface FieldGetCptr + procedure get_cptr + end interface + + interface FieldGetLocalSize + procedure get_local_size + end interface FieldGetLocalSize + + interface FieldGetLocalElementCount + procedure get_local_element_count + end interface FieldGetLocalElementCount + +contains + + + subroutine assign_fptr_r4_rank1(x, fptr, rc) + type(ESMF_Field), intent(inout) :: x + real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer(ESMF_KIND_I8), allocatable :: fp_shape(:) + integer(ESMF_KIND_I8) :: local_size + integer :: status + + local_size = FieldGetLocalSize(x, _RC) + fp_shape = [ local_size ] + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r4_rank1 + + subroutine assign_fptr_r8_rank1(x, fptr, rc) + type(ESMF_Field), intent(inout) :: x + real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer(ESMF_KIND_I8), allocatable :: fp_shape(:) + integer(ESMF_KIND_I8) :: local_size + integer :: status + + local_size = FieldGetLocalSize(x, _RC) + fp_shape = [ local_size ] + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r8_rank1 + + subroutine assign_fptr_r4_rank2(x, fp_shape, fptr, rc) + type(ESMF_Field), intent(inout) :: x + integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) + real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:,:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer :: status + + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r4_rank2 + + subroutine assign_fptr_r8_rank2(x, fp_shape, fptr, rc) + type(ESMF_Field), intent(inout) :: x + integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) + real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:,:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer :: status + + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r8_rank2 + + subroutine get_cptr(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_x + + call ESMF_FieldGet(x, typekind=tk_x, _RC) + + if (tk_x == ESMF_TYPEKIND_R4) then + call get_cptr_r4(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_R8) then + call get_cptr_r8(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_I4) then + call get_cptr_i4(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_I8) then + call get_cptr_i8(x, cptr, _RC) + else + _FAIL('Unsupported typekind in FieldGetCptr().') + end if + + _RETURN(_SUCCESS) + end subroutine get_cptr + + subroutine get_cptr_r4(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + real(kind=ESMF_KIND_R4), pointer :: x_1d(:) + real(kind=ESMF_KIND_R4), pointer :: x_2d(:,:) + real(kind=ESMF_KIND_R4), pointer :: x_3d(:,:,:) + real(kind=ESMF_KIND_R4), pointer :: x_4d(:,:,:,:) + real(kind=ESMF_KIND_R4), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_r4 + + subroutine get_cptr_r8(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + real(kind=ESMF_KIND_R8), pointer :: x_1d(:) + real(kind=ESMF_KIND_R8), pointer :: x_2d(:,:) + real(kind=ESMF_KIND_R8), pointer :: x_3d(:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_4d(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_r8 + + subroutine get_cptr_i4(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + integer(kind=ESMF_KIND_I4), pointer :: x_1d(:) + integer(kind=ESMF_KIND_I4), pointer :: x_2d(:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_3d(:,:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_4d(:,:,:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_i4 + + subroutine get_cptr_i8(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + integer(kind=ESMF_KIND_I8), pointer :: x_1d(:) + integer(kind=ESMF_KIND_I8), pointer :: x_2d(:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_3d(:,:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_4d(:,:,:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_i8 + + function get_local_element_count(x, rc) result(element_count) + type(ESMF_Field), intent(inout) :: x + integer, optional, intent(out) :: rc + integer, allocatable :: element_count(:) + + integer :: status + integer :: rank + +! element_count = [integer :: ] ! default + + call ESMF_FieldGet(x, rank=rank, _RC) + allocate(element_count(rank)) + call ESMF_FieldGet(x, localElementCount=element_count, _RC) + + _RETURN(_SUCCESS) + end function get_local_element_count + + function get_local_size(x, rc) result(sz) + integer(kind=ESMF_KIND_I8) :: sz + type(ESMF_Field), intent(inout) :: x + integer, optional, intent(out) :: rc + + integer :: status + integer, allocatable :: element_count(:) + + sz = 0 + element_count = FieldGetLocalElementCount(x, _RC) + sz = int(product(element_count), kind=ESMF_KIND_I8) + + _RETURN(_SUCCESS) + end function get_local_size + +end module diff --git a/geom/FieldUtilities.F90 b/geom/FieldUtilities.F90 new file mode 100644 index 000000000000..2c1b0ab62391 --- /dev/null +++ b/geom/FieldUtilities.F90 @@ -0,0 +1,95 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldUtilities +use ESMF +use MAPL_ErrorHandlingMod +use MAPL_FieldPointerUtilities + +implicit none +private + +public FieldIsConstant +public FieldSet + +interface FieldSet + module procedure FieldSet_R4 + module procedure FieldSet_R8 +end interface + + +contains + +function FieldIsConstant(field,constant_val,rc) result(field_is_constant) + logical :: field_is_constant + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_R4) :: constant_val + integer, optional, intent(out) :: rc + + integer :: status + + real(ESMF_KIND_R4), pointer :: f_ptr_r4(:),ptr2d(:,:) + + type(ESMF_TypeKind_Flag) :: type_kind + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + + field_is_constant = .false. + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + field_is_constant = all(f_ptr_r4 == constant_val) + else + _FAIL("constant_val is single precision so you can not check if it is all undef for an R8") + end if + + _RETURN(_SUCCESS) + +end function + +subroutine FieldSet_r8(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_r8), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status, rank + + call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + f_ptr_r4 = constant_val + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + f_ptr_r8 = constant_val + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldSet_r8 + +subroutine FieldSet_r4(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_r4), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status, rank + + call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + f_ptr_r4 = constant_val + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + f_ptr_r8 = constant_val + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldSet_r4 + +end module + diff --git a/geom/geom.F90 b/geom/geom.F90 new file mode 100644 index 000000000000..b64c6bafdef6 --- /dev/null +++ b/geom/geom.F90 @@ -0,0 +1,5 @@ +module MAPL_Geom + use MAPL_FieldUtilities + use MAPL_FieldPointerUtilities + use mapl3g_FieldBlas +end module diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 438e53fc4ffc..01125edccbc4 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -3,6 +3,7 @@ module Test_FieldBLAS use mapl3g_FieldBLAS + use MAPL_FieldPointerUtilities use ESMF use funit use MAPL_ExceptionHandling diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 51a77b201417..40157839d8ea 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -175,6 +175,6 @@ endif () # Unit testing -if (PFUNIT_FOUND) - add_subdirectory(tests EXCLUDE_FROM_ALL) -endif () +#if (PFUNIT_FOUND) + #add_subdirectory(tests EXCLUDE_FROM_ALL) +#endif () From 2700c6b92c98c77792ce435976f34672405da28a Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 25 May 2023 15:25:02 -0400 Subject: [PATCH 06/93] more movement --- geom/FieldBLAS.F90 | 163 --------------------------------- geom/FieldPointerUtilities.F90 | 158 ++++++++++++++++++++++++++++++++ 2 files changed, 158 insertions(+), 163 deletions(-) diff --git a/geom/FieldBLAS.F90 b/geom/FieldBLAS.F90 index ca5cccf72e10..9e9604ff7348 100644 --- a/geom/FieldBLAS.F90 +++ b/geom/FieldBLAS.F90 @@ -41,12 +41,7 @@ module mapl3g_FieldBLAS ! Misc utiliities public :: FieldSpread - public :: FieldClone public :: FieldConvertPrec - public :: FieldsAreConformable - public :: FieldsAreSameTypeKind -!wdb fixme temporary to test out this helper function - public :: assign_fptr ! call FieldCOPY(x, y, rc): y = x interface FieldCOPY @@ -72,11 +67,6 @@ module mapl3g_FieldBLAS procedure gemv_r8 end interface - interface FieldsAreConformable - procedure are_conformable_scalar - procedure are_conformable_array - end interface - interface FieldConvertPrec module procedure convert_prec end interface FieldConvertPrec @@ -85,14 +75,6 @@ module mapl3g_FieldBLAS module procedure spread_scalar end interface FieldSpread - interface FieldClone - module procedure clone - end interface FieldClone - - interface FieldsAreSameTypeKind - module procedure are_same_type_kind - end interface FieldsAreSameTypeKind - interface verify_typekind module procedure verify_typekind_scalar module procedure verify_typekind_array @@ -414,39 +396,6 @@ function spread_scalar(source, ncopies, rc) result(vector) _RETURN(_SUCCESS) end function spread_scalar - subroutine clone(x, y, rc) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - character(len=*), parameter :: CLONE_TAG = '_clone' - type(ESMF_ArraySpec) :: arrayspec - type(ESMF_Grid) :: grid - type(ESMF_StaggerLoc) :: staggerloc - integer, allocatable :: gridToFieldMap(:) - integer, allocatable :: ungriddedLBound(:) - integer, allocatable :: ungriddedUBound(:) - integer, allocatable :: totalLWidth(:,:) - integer, allocatable :: totalUWidth(:,:) - character(len=:), allocatable :: name - integer :: status - - call ESMF_FieldGet(x, arrayspec=arrayspec, grid=grid, & - staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & - totalLWidth=totalLWidth, totalUWidth=totalUWidth, _RC) - - name = name // CLONE_TAG - - y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & - gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & - ungriddedUBound=ungriddedUBound, name=name, _RC) -! ungriddedUBound=ungriddedUBound, totalLWidth=totalLWidth, & -! totalUWidth=totalUWidth, name=name, _RC) - - _RETURN(_SUCCESS) - end subroutine clone - subroutine get_typekind(x, expected_tks, actual_tk, rc) type(ESMF_Field), intent(inout) :: x type(ESMF_TypeKind_Flag), intent(in) :: expected_tks(:) @@ -583,116 +532,4 @@ subroutine convert_prec_R8_to_R4(original, converted, rc) _RETURN(_SUCCESS) end subroutine convert_prec_R8_to_R4 - logical function are_conformable_scalar(x, y, rc) result(conformable) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - integer :: rank_x, rank_y - integer, dimension(:), allocatable :: count_x, count_y - integer :: status - - conformable = .false. - - call ESMF_FieldGet(x, rank=rank_x, _RC) - call ESMF_FieldGet(y, rank=rank_y, _RC) - - if(rank_x == rank_y) then - count_x = FieldGetLocalElementCount(x, _RC) - count_y = FieldGetLocalElementCount(y, _RC) - conformable = all(count_x == count_y) - end if - - _RETURN(_SUCCESS) - end function are_conformable_scalar - - logical function are_conformable_array(x, y, rc) result(conformable) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y(:) - integer, optional, intent(out) :: rc - - integer :: status - integer :: j - logical :: element_not_conformable - - conformable = .false. - element_not_conformable = .false. - - do j = 1, size(y) - element_not_conformable = .not. FieldsAreConformable(x, y(j), _RC) - if(element_not_conformable) return - end do - - conformable = .true. - - _RETURN(_SUCCESS) - end function are_conformable_array -! logical function are_conformable_array_array(x, y) result(conformable) -! type(ESMF_Field), intent(inout) :: x(:) -! type(ESMF_Field), intent(inout) :: y(:) -! -! integer :: status -! integer :: j -! -! conformable = .false. -! -! if(size(x) == 1) then -! do j = 1, size(y) -! if(.not. FieldsAreConformable(x(1), y(j))) return -! end do -! elseif(size(x) == size(y)) then -! do j = 1, size(y) -! if(.not. FieldsAreConformable(x(j), y(j))) return -! end do -! else -! return -! end if -! -! conformable = .true. -! -! end function are_conformable_array_array -! -! logical function are_conformable_scalar_array(x, y, rc) result(conformable) -! type(ESMF_Field), intent(inout) :: x -! type(ESMF_Field), intent(inout) :: y(:) -! integer, optional, intent(out) :: rc -! -! integer :: status -! integer :: j -! -! do j = 1, size(y) -! conformable = FieldsAreConformable(x, y(j)) -! end do -! -! _RETURN(_SUCCESS) -! end function are_conformable_scalar_array -! -! logical function are_conformable_array_scalar(x, y, rc) result(conformable) -! type(ESMF_Field), intent(inout) :: x(:) -! type(ESMF_Field), intent(inout) :: y -! integer, optional, intent(out) :: rc -! -! integer :: status -! -! conformable = FieldsAreConformable(y, x) -! -! _RETURN(_SUCCESS) -! end function are_conformable_array_scalar - - logical function are_same_type_kind(x, y, rc) result(same_tk) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - integer :: status - type(ESMF_TypeKind_Flag) :: tk_x, tk_y - - same_tk = .false. - call ESMF_FieldGet(x, typekind=tk_x, _RC) - call ESMF_FieldGet(y, typekind=tk_y, _RC) - - same_tk = (tk_x == tk_y) - - _RETURN(_SUCCESS) - end function are_same_type_kind - end module mapl3g_FieldBLAS diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index c8e1ca487d55..73288dc6acaf 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -12,6 +12,9 @@ module MAPL_FieldPointerUtilities public :: FieldGetLocalElementCount public :: FieldGetLocalSize public :: FieldGetCptr + public :: FieldClone + public :: FieldsAreConformable + public :: FieldsAreSameTypeKind interface assign_fptr module procedure assign_fptr_r4_rank1 @@ -32,6 +35,24 @@ module MAPL_FieldPointerUtilities procedure get_local_element_count end interface FieldGetLocalElementCount + interface FieldsAreConformable + procedure are_conformable_scalar + procedure are_conformable_array + end interface + + interface FieldClone + module procedure clone + end interface FieldClone + + interface FieldsAreSameTypeKind + module procedure are_same_type_kind + end interface FieldsAreSameTypeKind + + interface verify_typekind + module procedure verify_typekind_scalar + module procedure verify_typekind_array + end interface verify_typekind + contains @@ -314,4 +335,141 @@ function get_local_size(x, rc) result(sz) _RETURN(_SUCCESS) end function get_local_size + subroutine clone(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + character(len=*), parameter :: CLONE_TAG = '_clone' + type(ESMF_ArraySpec) :: arrayspec + type(ESMF_Grid) :: grid + type(ESMF_StaggerLoc) :: staggerloc + integer, allocatable :: gridToFieldMap(:) + integer, allocatable :: ungriddedLBound(:) + integer, allocatable :: ungriddedUBound(:) + integer, allocatable :: totalLWidth(:,:) + integer, allocatable :: totalUWidth(:,:) + character(len=:), allocatable :: name + integer :: status + + call ESMF_FieldGet(x, arrayspec=arrayspec, grid=grid, & + staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & + totalLWidth=totalLWidth, totalUWidth=totalUWidth, _RC) + + name = name // CLONE_TAG + + y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & + gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & + ungriddedUBound=ungriddedUBound, name=name, _RC) +! ungriddedUBound=ungriddedUBound, totalLWidth=totalLWidth, & +! totalUWidth=totalUWidth, name=name, _RC) + + _RETURN(_SUCCESS) + end subroutine clone + + logical function are_conformable_scalar(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + integer :: rank_x, rank_y + integer, dimension(:), allocatable :: count_x, count_y + integer :: status + + conformable = .false. + + call ESMF_FieldGet(x, rank=rank_x, _RC) + call ESMF_FieldGet(y, rank=rank_y, _RC) + + if(rank_x == rank_y) then + count_x = FieldGetLocalElementCount(x, _RC) + count_y = FieldGetLocalElementCount(y, _RC) + conformable = all(count_x == count_y) + end if + + _RETURN(_SUCCESS) + end function are_conformable_scalar + + logical function are_conformable_array(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y(:) + integer, optional, intent(out) :: rc + + integer :: status + integer :: j + logical :: element_not_conformable + + conformable = .false. + element_not_conformable = .false. + + do j = 1, size(y) + element_not_conformable = .not. FieldsAreConformable(x, y(j), _RC) + if(element_not_conformable) return + end do + + conformable = .true. + + _RETURN(_SUCCESS) + end function are_conformable_array + + logical function are_same_type_kind(x, y, rc) result(same_tk) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + + same_tk = .false. + call ESMF_FieldGet(x, typekind=tk_x, _RC) + call ESMF_FieldGet(y, typekind=tk_y, _RC) + + same_tk = (tk_x == tk_y) + + _RETURN(_SUCCESS) + end function are_same_type_kind + + subroutine verify_typekind_scalar(x, expected_tk, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_TypeKind_Flag), intent(in) :: expected_tk + integer, optional, intent(out) :: rc + + integer :: status + + type(ESMF_TypeKind_Flag) :: found_tk + + call ESMF_FieldGet(x, typekind=found_tk, _RC) + + _ASSERT((found_tk == expected_tk), 'Found incorrect typekind.') + _RETURN(_SUCCESS) + end subroutine verify_typekind_scalar + + subroutine verify_typekind_array(x, expected_tk, rc) + type(ESMF_Field), intent(inout) :: x(:) + type(ESMF_TypeKind_Flag), intent(in) :: expected_tk + integer, optional, intent(out) :: rc + + integer :: status + integer :: i + + do i = 1, size(x) + call verify_typekind(x(i), expected_tk, _RC) + end do + _RETURN(_SUCCESS) + end subroutine verify_typekind_array + + function is_valid_typekind(actual_tk, valid_tks) result(is_valid) + type(ESMF_TypeKind_Flag), intent(in) :: actual_tk + type(ESMF_TypeKind_Flag), intent(in) :: valid_tks(:) + logical :: is_valid + integer :: i + + is_valid = .FALSE. + do i = 1, size(valid_tks) + is_valid = (actual_tk == valid_tks(i)) + if(is_valid) return + end do + + end function is_valid_typekind + end module From 50d0221d4976f90183d7d1d9ba19c2aa55a8344a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 31 May 2023 12:17:48 -0400 Subject: [PATCH 07/93] Update to ESMA_env 4.17.0 and ESMA_cmake v3.29.0 --- .circleci/config.yml | 2 +- .github/workflows/workflow.yml | 4 ++-- CHANGELOG.md | 18 ++++++++++++++++-- components.yaml | 4 ++-- 4 files changed, 21 insertions(+), 7 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 278b24dc6ffd..989649e8f85f 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -16,7 +16,7 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 -baselibs_version: &baselibs_version v7.7.0 +baselibs_version: &baselibs_version v7.13.0 bcs_version: &bcs_version v11.00.0 tag_build_arg_name: &tag_build_arg_name maplversion diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index ac6ebd4acf39..b73ba9bbbcfa 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.7.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.13.0-openmpi_4.1.4-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -77,7 +77,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.7.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.13.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CHANGELOG.md b/CHANGELOG.md index e2711d85b784..fbe6aab34621 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,20 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed - Updated programs using FLAP for command line parsing to use fArgParse instead +- Updated `components.yaml` to match GEOSgcm v11.1.0 + - ESMA_env v4.9.1 → v4.17.0 + - Baselibs 7.13.0 + - esmf v8.5.0b22 + - GFE v1.10.0 + - curl 8.1.1 + - HDF5 1.10.10 + - netCDF-C 4.9.2 + - netCDF-Fortran 4.6.1 + - CDO 2.2.0 + - NCO 5.1.5 + - Move to MPT 2.28 at NAS, and other various changes for TOSS4 at NAS + - ESMA_cmake v3.28.0 → v3.29.0 + - Clean up for TOSS4 changes at NAS ### Fixed @@ -19,6 +33,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +- Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 + ## [2.39.2] - 2023-05-30 ### Fixed @@ -92,8 +108,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Pulled call MAPL_GridGetCorners out of the condition to avoid hang in MAPL_GetGlobalHorzIJIndex -- Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 - ## [2.37.1] - 2023-04-14 ### Fixed diff --git a/components.yaml b/components.yaml index 615e0a155a61..1a9d754c9506 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.9.1 + tag: v4.17.0 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.28.0 + tag: v3.29.0 develop: develop ecbuild: From fc54c489c6bf651c3f4d694e86adf611136241d7 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 31 May 2023 13:01:28 -0400 Subject: [PATCH 08/93] Move GEOSadas build to separate test --- .circleci/config.yml | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 989649e8f85f..f03ab4d40ea1 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -148,25 +148,6 @@ workflows: fixture_branch: develop checkout_mapl_branch: true - # Build GEOSadas (ifort only, needs a couple develop branches) - - ci/build: - name: build-GEOSadas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - resource_class: xlarge - baselibs_version: *baselibs_version - repo: GEOSadas - checkout_fixture: true - # This branch on GEOSadas will be used to track subrepos needed - # for GEOSadas + MAPL develop much like how we do with MAPL 3 - #fixture_branch: feature/mathomp4/mapldevelop - checkout_mapl_branch: true - mepodevelop: false - rebuild_procs: 1 - # Run GCM (1 hour, no ExtData) - ci/run_gcm: name: run-GCM-on-<< matrix.compiler >> @@ -218,6 +199,27 @@ workflows: - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version + build-GEOSadas: + jobs: + # Build GEOSadas (ifort only, needs a couple develop branches) + - ci/build: + name: build-GEOSadas-on-<< matrix.compiler >> + context: + - docker-hub-creds + matrix: + parameters: + compiler: [ifort] + resource_class: xlarge + baselibs_version: *baselibs_version + repo: GEOSadas + checkout_fixture: true + # This branch on GEOSadas will be used to track subrepos needed + # for GEOSadas + MAPL develop much like how we do with MAPL 3 + #fixture_branch: feature/mathomp4/mapldevelop + checkout_mapl_branch: true + mepodevelop: false + rebuild_procs: 1 + build-and-publish-docker: when: equal: [ "release", << pipeline.parameters.GHA_Event >> ] From e0413eead5050153147abef969715b56e6535e54 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 2 Jun 2023 13:06:51 -0400 Subject: [PATCH 09/93] create cubed-sphere grid factory with restart file split by face --- base/MAPL_GridManager.F90 | 14 +++++++++++++- generic/MAPL_Generic.F90 | 27 ++++++++++++++++++++------- 2 files changed, 33 insertions(+), 8 deletions(-) diff --git a/base/MAPL_GridManager.F90 b/base/MAPL_GridManager.F90 index e3b0ac058717..706d4d29192f 100644 --- a/base/MAPL_GridManager.F90 +++ b/base/MAPL_GridManager.F90 @@ -491,6 +491,19 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, _VERIFY(status) file_metadata = file_formatter%read(rc=status) _VERIFY(status) + call file_formatter%close(rc=status) + _VERIFY(status) + + if (file_metadata%has_attribute("Cubed_Sphere_Face_Index")) then + if (file_metadata%has_dimension('lat')) then + jm = file_metadata%get_dimension('lat') + call file_metadata%modify_dimension('lat', jm*6) + endif + if (file_metadata%has_dimension('latitude')) then + jm = file_metadata%get_dimension('latitude') + call file_metadata%modify_dimension('latitude', jm*6) + endif + endif im = 0 hasXdim = file_metadata%has_dimension('Xdim') @@ -561,7 +574,6 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, call factory%initialize(file_metadata, force_file_coordinates=force_file_coordinates, rc=status) _VERIFY(status) - call file_formatter%close(rc=status) _RETURN(_SUCCESS) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index f5dbc948bd13..c8631d1a3b3c 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -6306,13 +6306,26 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_AttributeGet(MPL%GRID%ESMFGRID,'GridType',value=grid_type,rc=status) _VERIFY(status) end if - !note this only works for geos cubed-sphere restarts currently because of - !possible insufficent metadata in the other restarts to support the other grid factories - if (trim(grid_type) == 'Cubed-Sphere') then - app_factory => get_factory(MPL%GRID%ESMFGRID) - allocate(file_factory,source=grid_manager%make_factory(trim(fname))) - _ASSERT(file_factory%physical_params_are_equal(app_factory),"Factories not equal") - end if + + block + !note this only works for geos cubed-sphere restarts currently because of + !possible insufficent metadata in the other restarts to support the other grid factories + character(len=:), allocatable :: fname_by_face + logical :: fexist + if (trim(grid_type) == 'Cubed-Sphere') then + app_factory => get_factory(MPL%GRID%ESMFGRID) + ! at this point, arrdes%read_restart_by_face is not initialized + ! pick the first face + fname_by_face = get_fname_by_face(trim(fname), 1) + inquire(FILE = trim(fname_by_face), EXIST=fexist) + if(fexist) then + allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) + else + allocate(file_factory,source=grid_manager%make_factory(trim(fname))) + endif + _ASSERT(file_factory%physical_params_are_equal(app_factory),"Factories not equal") + end if + end block call ArrDescrSetNCPar(arrdes,MPL,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) end if PNC4_TILE From 86e311db289f83d266c4ec89e6681f375e06e4eb Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 2 Jun 2023 13:09:44 -0400 Subject: [PATCH 10/93] change log --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index e16791fe8a64..1564a9fa279b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Created cubed-sphere grid factory with files slit by face + ### Removed ### Deprecated From aab5a7b1f9bce9ef245ee35361870f917c324572 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 5 Jun 2023 11:15:04 -0400 Subject: [PATCH 11/93] simplify checking --- base/MAPL_GridManager.F90 | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/base/MAPL_GridManager.F90 b/base/MAPL_GridManager.F90 index 706d4d29192f..ddee627d4297 100644 --- a/base/MAPL_GridManager.F90 +++ b/base/MAPL_GridManager.F90 @@ -479,7 +479,8 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, logical :: hasLongitude = .FALSE. logical :: hasLat = .FALSE. logical :: hasLatitude = .FALSE. - + logical :: splitByface = .FALSE. + _UNUSED_DUMMY(unused) call ESMF_VMGetCurrent(vm, rc=status) @@ -494,16 +495,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, call file_formatter%close(rc=status) _VERIFY(status) - if (file_metadata%has_attribute("Cubed_Sphere_Face_Index")) then - if (file_metadata%has_dimension('lat')) then - jm = file_metadata%get_dimension('lat') - call file_metadata%modify_dimension('lat', jm*6) - endif - if (file_metadata%has_dimension('latitude')) then - jm = file_metadata%get_dimension('latitude') - call file_metadata%modify_dimension('latitude', jm*6) - endif - endif + splitByface = file_metadata%has_attribute("Cubed_Sphere_Face_Index") im = 0 hasXdim = file_metadata%has_dimension('Xdim') @@ -539,7 +531,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, if (status == _SUCCESS) then jm = file_metadata%get_dimension('Ydim',rc=status) _VERIFY(status) - if (jm == 6*im) then + if (jm == 6*im .or. splitByface) then allocate(factory, source=this%make_clone('Cubed-Sphere')) else nf = file_metadata%get_dimension('nf',rc=status) @@ -562,7 +554,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, end if end if - if (jm == 6*im) then ! old-format cubed-sphere + if (jm == 6*im .or. splitByface) then ! old-format cubed-sphere allocate(factory, source=this%make_clone('Cubed-Sphere')) !!$ elseif (...) then ! something that is true for tripolar? !!$ factory = this%make_clone('tripolar') From 49226c253607f615942ed77dff2966aca42ec7f5 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Mon, 5 Jun 2023 11:31:26 -0400 Subject: [PATCH 12/93] Update CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1564a9fa279b..9a206fce8d62 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,7 +13,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed -- Created cubed-sphere grid factory with files slit by face +- Created cubed-sphere grid factory with files split by face ### Removed From 623884093ec968d94a730506f1cf5cd220fdb2d4 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 5 Jun 2023 13:07:28 -0400 Subject: [PATCH 13/93] lots of utilities to do math on fields... --- geom/CMakeLists.txt | 3 + geom/FieldBLAS.F90 | 109 ------------------- geom/FieldBinaryOperations.F90 | 42 ++++++++ geom/FieldBinaryOperatorTemplate.H | 51 +++++++++ geom/FieldFunctionTemplate.H | 41 ++++++++ geom/FieldFunctions.F90 | 85 +++++++++++++++ geom/FieldPointerUtilities.F90 | 114 +++++++++++++++++++- geom/FieldUtilities.F90 | 92 ++++++++++++++-- geom/function_overload.macro | 4 + geom/tests/CMakeLists.txt | 2 + geom/tests/Test_FieldArithmetic.pf | 162 +++++++++++++++++++++++++++++ geom/tests/Test_FieldBLAS.pf | 159 +++------------------------- geom/tests/geom_setup.F90 | 162 +++++++++++++++++++++++++++++ geom/undo_function_overload.macro | 5 + 14 files changed, 765 insertions(+), 266 deletions(-) create mode 100644 geom/FieldBinaryOperations.F90 create mode 100644 geom/FieldBinaryOperatorTemplate.H create mode 100644 geom/FieldFunctionTemplate.H create mode 100644 geom/FieldFunctions.F90 create mode 100644 geom/function_overload.macro create mode 100644 geom/tests/Test_FieldArithmetic.pf create mode 100644 geom/tests/geom_setup.F90 create mode 100644 geom/undo_function_overload.macro diff --git a/geom/CMakeLists.txt b/geom/CMakeLists.txt index 4fa2f2dd7036..4194f6ab1246 100644 --- a/geom/CMakeLists.txt +++ b/geom/CMakeLists.txt @@ -15,6 +15,8 @@ set(srcs FieldBLAS.F90 FieldPointerUtilities.F90 FieldUtilities.F90 + FieldFunctions.F90 + FieldBinaryOperations.F90 ) # Workaround for strict NAG Fortran with ESMF implicit interface for private state. #set_property( SOURCE InnerMetaComponent.F90 OuterMetaComponent.F90 @@ -34,6 +36,7 @@ esma_add_library(${this} DEPENDENCIES MAPL.shared PFLOGGER::pflogger TYPE ${MAPL_LIBRARY_TYPE} ) + #add_subdirectory(specs) #add_subdirectory(registry) #add_subdirectory(connection_pt) diff --git a/geom/FieldBLAS.F90 b/geom/FieldBLAS.F90 index 9e9604ff7348..fdc6a8f338b9 100644 --- a/geom/FieldBLAS.F90 +++ b/geom/FieldBLAS.F90 @@ -10,7 +10,6 @@ module mapl3g_FieldBLAS private ! Level 1 BLAS - public :: FieldCOPY public :: FieldSCAL public :: FieldAXPY @@ -43,11 +42,6 @@ module mapl3g_FieldBLAS public :: FieldSpread public :: FieldConvertPrec - ! call FieldCOPY(x, y, rc): y = x - interface FieldCOPY - procedure copy - end interface FieldCOPY - !wdb fixme This acts on y in-place. Do we need a form that acts more like a function: y = FieldSCAL(a, x)? ! call FieldSCAL(a, x, rc): x = a*x (multiply x in-place) interface FieldSCAL @@ -82,109 +76,6 @@ module mapl3g_FieldBLAS contains - !wdb fixme Is this a deep copy? - subroutine copy(x, y, rc) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - type(ESMF_TypeKind_Flag) :: tk_x, tk_y - type(c_ptr) :: cptr_x, cptr_y - integer(kind=ESMF_KIND_I8) :: n - integer :: status - logical :: conformable - logical :: x_is_double - logical :: y_is_double - character(len=*), parameter :: UNSUPPORTED_TK = & - 'Unsupported typekind in FieldCOPY() for ' - - conformable = FieldsAreConformable(x, y) - !wdb fixme need to pass RC - _ASSERT(conformable, 'FieldCopy() - fields not conformable.') - call FieldGetCptr(x, cptr_x, _RC) - call ESMF_FieldGet(x, typekind = tk_x, _RC) - - n = FieldGetLocalSize(x, _RC) - - call FieldGetCptr(y, cptr_y, _RC) - call ESMF_FieldGet(y, typekind = tk_y, _RC) - - !wdb fixme convert between precisions ? get rid of extra cases - y_is_double = (tk_y == ESMF_TYPEKIND_R8) - _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') - - x_is_double = (tk_x == ESMF_TYPEKIND_R8) - _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') - - if (y_is_double) then - if (x_is_double) then - call copy_r8_r8(cptr_x, cptr_y, n) - else - call copy_r4_r8(cptr_x, cptr_y, n) - end if - else - if (x_is_double) then - call copy_r8_r4(cptr_x, cptr_y, n) - else - call copy_r4_r4(cptr_x, cptr_y, n) - end if - end if - - _RETURN(_SUCCESS) - end subroutine copy - - subroutine copy_r4_r4(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r4_r4 - - subroutine copy_r4_r8(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r4_r8 - - subroutine copy_r8_r4(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r8_r4 - - subroutine copy_r8_r8(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r8_r8 - subroutine scale_r4(a, x, rc) real(kind=ESMF_KIND_R4), intent(in) :: a type(ESMF_Field), intent(inout) :: x diff --git a/geom/FieldBinaryOperations.F90 b/geom/FieldBinaryOperations.F90 new file mode 100644 index 000000000000..c675f0e5a908 --- /dev/null +++ b/geom/FieldBinaryOperations.F90 @@ -0,0 +1,42 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldBinaryOperations + use ESMF + use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + implicit none + private + + public fieldAdd + public fieldSubtract + public fieldDivide + public fieldMultiply + + contains + +#define _OP + +#define _FUNC Add +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP - +#define _FUNC Subtract +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP * +#define _FUNC Multiply +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP / +#define _FUNC Divide +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +end module MAPL_FieldBinaryOperations diff --git a/geom/FieldBinaryOperatorTemplate.H b/geom/FieldBinaryOperatorTemplate.H new file mode 100644 index 000000000000..8f9f6e79d9e1 --- /dev/null +++ b/geom/FieldBinaryOperatorTemplate.H @@ -0,0 +1,51 @@ +#define _NAME field +#include "function_overload.macro" + + subroutine _SUB(field_a,field_b,undef,rc) + type(ESMF_Field), intent(inout) :: field_a + type(ESMF_Field), intent(inout) :: field_b + real, optional, intent(in) :: undef + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_a,tk_b + + real(kind=ESMF_KIND_R4), pointer :: ptr1_r4(:), ptr2_r4(:) + real(kind=ESMF_KIND_R8), pointer :: ptr1_r8(:), ptr2_r8(:) + + call ESMF_FieldGet(field_a,typekind=tk_a,_RC) + call ESMF_FieldGet(field_b,typekind=tk_b,_RC) + + _ASSERT(tk_a==tk_b, "For now we will only allow operations on same type fields") + if (tk_a ==ESMF_TypeKind_R4) then + call assign_fptr(field_a,ptr1_r4,_RC) + call assign_fptr(field_b,ptr2_r4,_RC) + if (present(undef)) then + where( (ptr1_r4 /= undef) .and. (ptr2_r4 /= undef) ) + ptr1_r4 = ptr1_r4 _OP ptr2_r4 + else where + ptr1_r4 = undef + end where + else + ptr1_r4 = ptr1_r4 _OP ptr2_r4 + end if + else if (tk_A == ESMF_TypeKind_R8) then + call assign_fptr(field_a,ptr1_r8,_RC) + call assign_fptr(field_b,ptr2_r8,_RC) + if (present(undef)) then + where( (ptr1_r8 /= undef) .and. (ptr2_r8 /= undef) ) + ptr1_r8 = ptr1_r8 _OP ptr2_r8 + else where + ptr1_r8 = undef + end where + else + ptr1_r8 = ptr1_r8 _OP ptr2_r8 + end if + else + _FAIL("unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine _SUB + +#include "undo_function_overload.macro" +#undef _NAME diff --git a/geom/FieldFunctionTemplate.H b/geom/FieldFunctionTemplate.H new file mode 100644 index 000000000000..0c0af6fd7e75 --- /dev/null +++ b/geom/FieldFunctionTemplate.H @@ -0,0 +1,41 @@ +#define _NAME field +#include "function_overload.macro" + + subroutine _SUB(field,undef,rc) + type(ESMF_Field), intent(inout) :: field + real, optional, intent(in) :: undef + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk + + real(kind=ESMF_KIND_R4), pointer :: ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: ptr_r8(:) + + call ESMF_FieldGet(field,typekind=tk,_RC) + if (tk ==ESMF_TypeKind_R4) then + call assign_fptr(field,ptr_r4,_RC) + if (present(undef)) then + where(ptr_r4 /= undef) + ptr_r4 = _FUNC(ptr_r4) + end where + else + ptr_r4 = _FUNC(ptr_r4) + end if + else if (tk == ESMF_TypeKind_R8) then + call assign_fptr(field,ptr_r8,_RC) + if (present(undef)) then + where(ptr_r8 /= undef) + ptr_r8 = _FUNC(ptr_r4) + end where + else + ptr_r8 = _FUNC(ptr_r8) + end if + else + _FAIL("unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine _SUB + +#include "undo_function_overload.macro" +#undef _NAME diff --git a/geom/FieldFunctions.F90 b/geom/FieldFunctions.F90 new file mode 100644 index 000000000000..2cd13a72cfdd --- /dev/null +++ b/geom/FieldFunctions.F90 @@ -0,0 +1,85 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldFunctions + use ESMF + use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + implicit none + private + + public :: fieldAbs + public :: fieldExp + public :: fieldLog10 + public :: fieldLog + public :: fieldSqrt + public :: fieldSinh + public :: fieldCosh + public :: fieldTanh + public :: fieldSin + public :: fieldCos + public :: fieldTan + public :: fieldAsin + public :: fieldAcos + public :: fieldAtan + +contains + +#define _FUNC Abs +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Exp +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Log10 +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Log +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sqrt +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sinh +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Cosh +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Tanh +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sin +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Cos +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Tan +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Asin +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Acos +#include "FieldFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Atan +#include "FieldFunctionTemplate.H" +#undef _FUNC + +end module MAPL_FieldFunctions + diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 73288dc6acaf..4c67af456596 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -15,6 +15,7 @@ module MAPL_FieldPointerUtilities public :: FieldClone public :: FieldsAreConformable public :: FieldsAreSameTypeKind + public :: FieldCopy interface assign_fptr module procedure assign_fptr_r4_rank1 @@ -53,6 +54,11 @@ module MAPL_FieldPointerUtilities module procedure verify_typekind_array end interface verify_typekind + ! call FieldCOPY(x, ddy, rc): y = x + interface FieldCOPY + procedure copy + end interface FieldCOPY + contains @@ -362,8 +368,6 @@ subroutine clone(x, y, rc) y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & ungriddedUBound=ungriddedUBound, name=name, _RC) -! ungriddedUBound=ungriddedUBound, totalLWidth=totalLWidth, & -! totalUWidth=totalUWidth, name=name, _RC) _RETURN(_SUCCESS) end subroutine clone @@ -472,4 +476,110 @@ function is_valid_typekind(actual_tk, valid_tks) result(is_valid) end function is_valid_typekind + subroutine copy(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + type(c_ptr) :: cptr_x, cptr_y + integer(kind=ESMF_KIND_I8) :: n + integer :: status + logical :: conformable + logical :: x_is_double + logical :: y_is_double + character(len=*), parameter :: UNSUPPORTED_TK = & + 'Unsupported typekind in FieldCOPY() for ' + + conformable = FieldsAreConformable(x, y) + !wdb fixme need to pass RC + _ASSERT(conformable, 'FieldCopy() - fields not conformable.') + call FieldGetCptr(x, cptr_x, _RC) + call ESMF_FieldGet(x, typekind = tk_x, _RC) + + n = FieldGetLocalSize(x, _RC) + + call FieldGetCptr(y, cptr_y, _RC) + call ESMF_FieldGet(y, typekind = tk_y, _RC) + + !wdb fixme convert between precisions ? get rid of extra cases + y_is_double = (tk_y == ESMF_TYPEKIND_R8) + _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') + + x_is_double = (tk_x == ESMF_TYPEKIND_R8) + _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') + + if (y_is_double) then + if (x_is_double) then + call copy_r8_r8(cptr_x, cptr_y, n) + else + call copy_r4_r8(cptr_x, cptr_y, n) + end if + else + if (x_is_double) then + call copy_r8_r4(cptr_x, cptr_y, n) + else + call copy_r4_r4(cptr_x, cptr_y, n) + end if + end if + + _RETURN(_SUCCESS) + end subroutine copy + + subroutine copy_r4_r4(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r4_r4 + + subroutine copy_r4_r8(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r4_r8 + + subroutine copy_r8_r4(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r8_r4 + + subroutine copy_r8_r8(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r8_r8 + + + + + end module diff --git a/geom/FieldUtilities.F90 b/geom/FieldUtilities.F90 index 2c1b0ab62391..45b423def7f7 100644 --- a/geom/FieldUtilities.F90 +++ b/geom/FieldUtilities.F90 @@ -10,16 +10,21 @@ module MAPL_FieldUtilities public FieldIsConstant public FieldSet +public FieldNegate +public FieldPow + +interface FieldIsConstant + module procedure FieldIsConstantR4 +end interface interface FieldSet module procedure FieldSet_R4 module procedure FieldSet_R8 end interface - contains -function FieldIsConstant(field,constant_val,rc) result(field_is_constant) +function FieldIsConstantR4(field,constant_val,rc) result(field_is_constant) logical :: field_is_constant type(ESMF_Field), intent(inout) :: field real(kind=ESMF_KIND_R4) :: constant_val @@ -27,7 +32,7 @@ function FieldIsConstant(field,constant_val,rc) result(field_is_constant) integer :: status - real(ESMF_KIND_R4), pointer :: f_ptr_r4(:),ptr2d(:,:) + real(ESMF_KIND_R4), pointer :: f_ptr_r4(:) type(ESMF_TypeKind_Flag) :: type_kind @@ -43,7 +48,7 @@ function FieldIsConstant(field,constant_val,rc) result(field_is_constant) _RETURN(_SUCCESS) -end function +end function FieldIsConstantR4 subroutine FieldSet_r8(field,constant_val,rc) type(ESMF_Field), intent(inout) :: field @@ -53,9 +58,9 @@ subroutine FieldSet_r8(field,constant_val,rc) type(ESMF_TYPEKIND_FLAG) :: type_kind real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) - integer :: status, rank + integer :: status - call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + call ESMF_FieldGet(field,typekind=type_kind,_RC) if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r4,_RC) f_ptr_r4 = constant_val @@ -76,9 +81,9 @@ subroutine FieldSet_r4(field,constant_val,rc) type(ESMF_TYPEKIND_FLAG) :: type_kind real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) - integer :: status, rank + integer :: status - call ESMF_FieldGet(field,rank=rank,typekind=type_kind,_RC) + call ESMF_FieldGet(field,typekind=type_kind,_RC) if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r4,_RC) f_ptr_r4 = constant_val @@ -91,5 +96,76 @@ subroutine FieldSet_r4(field,constant_val,rc) _RETURN(ESMF_SUCCESS) end subroutine FieldSet_r4 +subroutine FieldNegate(field,undef,rc) + type(ESMF_Field), intent(inout) :: field + real, optional, intent(in) :: undef + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + if (present(undef)) then + where(f_ptr_r4 /= undef) + f_ptr_r4 = -f_ptr_r4 + end where + else + f_ptr_r4 = -f_ptr_r4 + end if + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + if (present(undef)) then + where(f_ptr_r8 /= undef) + f_ptr_r8 = -f_ptr_r8 + end where + else + f_ptr_r8 = -f_ptr_r8 + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldNegate + +subroutine FieldPow(field,expo,undef,rc) + type(ESMF_Field), intent(inout) :: field + real, intent(in) :: expo + real, optional, intent(in) :: undef + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + if (present(undef)) then + where(f_ptr_r4 /= undef) + f_ptr_r4 = f_ptr_r4 ** expo + end where + else + f_ptr_r4 = f_ptr_r4**expo + end if + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + if (present(undef)) then + where(f_ptr_r8 /= undef) + f_ptr_r8 = f_ptr_r8 ** expo + end where + else + f_ptr_r8 = f_ptr_r8**expo + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldPow + end module diff --git a/geom/function_overload.macro b/geom/function_overload.macro new file mode 100644 index 000000000000..5b0fd54cf8dc --- /dev/null +++ b/geom/function_overload.macro @@ -0,0 +1,4 @@ +#define _IDENTITY(x)x +#define _SUB __SUB(_NAME,_FUNC) +#define __SUB(A,B) ___SUB(A,B) +#define ___SUB(A,B) _IDENTITY(A)_IDENTITY(B) diff --git a/geom/tests/CMakeLists.txt b/geom/tests/CMakeLists.txt index 77847896267d..5a250b45ceed 100644 --- a/geom/tests/CMakeLists.txt +++ b/geom/tests/CMakeLists.txt @@ -2,6 +2,7 @@ set(MODULE_DIRECTORY "${esma_include}/MAPL.geom/tests") set (test_srcs Test_FieldBLAS.pf + Test_FieldArithmetic.pf ) @@ -10,6 +11,7 @@ add_pfunit_ctest(MAPL.geom.tests LINK_LIBRARIES MAPL.geom MAPL.pfunit EXTRA_INITIALIZE Initialize EXTRA_USE MAPL_pFUnit_Initialize + OTHER_SOURCES geom_setup.F90 # OTHER_SOURCES MockUserGridComp.F90 MockItemSpec.F90 MAX_PES 4 ) diff --git a/geom/tests/Test_FieldArithmetic.pf b/geom/tests/Test_FieldArithmetic.pf new file mode 100644 index 000000000000..afaa1cebe929 --- /dev/null +++ b/geom/tests/Test_FieldArithmetic.pf @@ -0,0 +1,162 @@ +#include "MAPL_Generic.h" + +module Test_FieldArithmetic + + use geom_setup + use MAPL_FieldFunctions + use MAPL_FieldBinaryOperations + use MAPL_FieldUtilities + use MAPL_FieldPointerUtilities + use ESMF + use funit + use MAPL_ExceptionHandling + + implicit none + +contains + + @Before + subroutine set_up_data() + implicit none + + integer :: status, rc + + real(kind=ESMF_KIND_R4), parameter :: ADD_R4 = 100.0 + real(kind=ESMF_KIND_R8), parameter :: ADD_R8 = 100.0 + real(kind=ESMF_KIND_R4), allocatable :: y4array(:,:) + real(kind=ESMF_KIND_R8), allocatable :: y8array(:,:) + + allocate(y4array, source=R4_ARRAY_DEFAULT) + allocate(y8array, source=R8_ARRAY_DEFAULT) + y4array = y4array + ADD_R4 + y8array = y8array + ADD_R8 + XR4 = mk_field(R4_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'XR4', _RC) + YR4 = mk_field(y4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'YR4', _RC) + XR8 = mk_field(R8_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) + YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + + end subroutine set_up_data + + @Test + subroutine test_FieldAddR4() + type(ESMF_Field) :: x + type(ESMF_Field) :: y + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR4 + y = YR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = 2.0 + y_ptr = 3.0 + result_array = x_ptr + result_array = 5.0 + call FieldAdd(x, y, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldAddR4 + + @Test + subroutine test_FieldAddR4_missing + type(ESMF_Field) :: x + type(ESMF_Field) :: y + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + real :: undef + + x = XR4 + y = YR4 + undef = 42.0 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = reshape(source=[2.0,2.0,2.0,undef],shape=[2,2]) + y_ptr = reshape(source=[undef,3.0,3.0,undef],shape=[2,2]) + result_array = x_ptr + result_array = reshape(source=[undef,5.0,5.0,undef],shape=[2,2]) + call FieldAdd(x, y, undef=undef, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldAddR4_missing + + @Test + subroutine test_FieldAddR8() + type(ESMF_Field) :: x + type(ESMF_Field) :: y + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:), y_ptr(:,:) + real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR8 + y = YR8 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = 2.d0 + y_ptr = 3.d0 + result_array = x_ptr + result_array = 5.d0 + call FieldAdd(x, y, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldAddR8 + + @Test + subroutine test_FieldPowR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + real :: expo + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + expo = 4.0 + result_array = x_ptr + result_array = 2.0**expo + call FieldPow(x, expo, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldPowR4 + + @Test + subroutine test_FieldSinR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + result_array = x_ptr + result_array = sin(2.0) + call FieldSin(x, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldSinR4 + + @Test + subroutine test_FieldNegR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + result_array = x_ptr + result_array = -2.0 + call FieldNegate(x, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldNegR4 + +end module Test_FieldArithmetic diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 01125edccbc4..1f7799142192 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -3,6 +3,7 @@ module Test_FieldBLAS use mapl3g_FieldBLAS + use geom_setup use MAPL_FieldPointerUtilities use ESMF use funit @@ -10,119 +11,8 @@ module Test_FieldBLAS implicit none - interface mk_field - module procedure mk_field_r4 - module procedure mk_field_r8 - end interface mk_field - - interface initialize_array - module procedure initialize_array_R4 - module procedure initialize_array_R8 - end interface initialize_array - - integer :: i - type(ESMF_Index_Flag), parameter :: INDEX_FLAG_DEFAULT = ESMF_INDEX_DELOCAL - integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] - integer, parameter :: MAX_INDEX_DEFAULT(*) = [4, 4] - integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] - integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] - integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] - integer, parameter :: SIZE_R4 = 16 - integer, parameter :: SIZE_R8 = 16 - - real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R4)], DIMR4_DEFAULT) - real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R8)], DIMR8_DEFAULT) - - type(ESMF_Field) :: XR4 - type(ESMF_Field) :: XR8 - type(ESMF_Field) :: YR4 - type(ESMF_Field) :: YR8 - contains - ! MAKE GRID FOR FIELDS - function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result(grid) - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag - character(len=*), intent(in) :: grid_name - integer, optional, intent(out) :: rc - - type(ESMF_Grid) :: grid - - integer :: status - - grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, name = grid_name, _RC) - - _RETURN(_SUCCESS) - end function mk_grid - - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R4) - function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) - real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag - character(len=*), intent(in) :: name - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field - real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: ptr - - integer :: status - - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) - call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray - - _RETURN(_SUCCESS) - end function mk_field_r4 - - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R8) - function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) - real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag - character(len=*), intent(in) :: name - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field - real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: ptr - - integer :: status - - field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) - call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray - - _RETURN(_SUCCESS) - end function mk_field_r8 - - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) - type(ESMF_TypeKind_Flag), intent(in) :: tk - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag - character(len=*), intent(in) :: name - integer, optional, intent(out) :: rc - character(len=*), parameter :: GRID_SUFFIX = '_grid' - character(len=*), parameter :: FIELD_SUFFIX = '_field' - - type(ESMF_Field) :: field - type(ESMF_Grid) :: grid - integer :: status - - grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) - field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, _RC) - - _RETURN(_SUCCESS) - end function mk_field_common - @Before subroutine set_up_data() implicit none @@ -468,44 +358,19 @@ contains end subroutine test_FieldClone -!wdb setup routines - subroutine initialize_array_R4(x, xmin, xrange) - real(ESMF_KIND_R4), intent(inout) :: x(:,:) - real(ESMF_KIND_R4), intent(in) :: xmin - real(ESMF_KIND_R4), intent(in) :: xrange - integer :: rc - - _ASSERT(xrange > 0, 'Range for random numbers must be positive.') - call random_number(x) - x = xrange * x + xmin - - end subroutine initialize_array_R4 - - subroutine initialize_array_R8(x, xmin, xrange) - real(ESMF_KIND_R8), intent(inout) :: x(:,:) - real(ESMF_KIND_R8), intent(in) :: xmin - real(ESMF_KIND_R8), intent(in) :: xrange - integer :: rc - - _ASSERT(xrange > 0, 'Range for random numbers must be positive.') - call random_number(x) - x = xrange * x + xmin - - end subroutine initialize_array_R8 - - elemental function are_almost_equal(x, y) result(almost_equal) - real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) - real(kind=ESMF_KIND_R8), intent(in) :: x - real(kind=ESMF_KIND_R4), intent(in) :: y - logical :: almost_equal + !elemental function are_almost_equal(x, y) result(almost_equal) + !real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) + !real(kind=ESMF_KIND_R8), intent(in) :: x + !real(kind=ESMF_KIND_R4), intent(in) :: y + !logical :: almost_equal - if(y==0) then - almost_equal = (x==0) - else - almost_equal = (abs(x-y)/abs(y) < EPS) - end if + !if(y==0) then + !almost_equal = (x==0) + !else + !almost_equal = (abs(x-y)/abs(y) < EPS) + !end if - end function are_almost_equal + !end function are_almost_equal @Test subroutine test_almost_equal_scalar() diff --git a/geom/tests/geom_setup.F90 b/geom/tests/geom_setup.F90 new file mode 100644 index 000000000000..0302fcbb38c0 --- /dev/null +++ b/geom/tests/geom_setup.F90 @@ -0,0 +1,162 @@ +#include "MAPL_Generic.h" + +module geom_setup + + use ESMF + use funit + use MAPL_ExceptionHandling + + implicit none + + interface mk_field + module procedure mk_field_r4 + module procedure mk_field_r8 + end interface mk_field + + interface initialize_array + module procedure initialize_array_r4 + module procedure initialize_array_r8 + end interface + + integer :: i + type(ESMF_Index_Flag), parameter :: INDEX_FLAG_DEFAULT = ESMF_INDEX_DELOCAL + integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] + integer, parameter :: MAX_INDEX_DEFAULT(*) = [4, 4] + integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] + integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] + integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] + integer, parameter :: SIZE_R4 = 16 + integer, parameter :: SIZE_R8 = 16 + + real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R4)], DIMR4_DEFAULT) + real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R8)], DIMR8_DEFAULT) + + type(ESMF_Field) :: XR4 + type(ESMF_Field) :: XR8 + type(ESMF_Field) :: YR4 + type(ESMF_Field) :: YR8 + +contains + + ! MAKE GRID FOR FIELDS + function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result(grid) + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: grid_name + integer, optional, intent(out) :: rc + + type(ESMF_Grid) :: grid + + integer :: status + + grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, name = grid_name, _RC) + + _RETURN(_SUCCESS) + end function mk_grid + + ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R4) + function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: name + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: ptr + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + call ESMF_FieldGet(field, farrayPtr = ptr, _RC) + ptr => farray + + _RETURN(_SUCCESS) + end function mk_field_r4 + + ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R8) + function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: name + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: ptr + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + call ESMF_FieldGet(field, farrayPtr = ptr, _RC) + ptr => farray + + _RETURN(_SUCCESS) + end function mk_field_r8 + + function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + type(ESMF_TypeKind_Flag), intent(in) :: tk + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: name + integer, optional, intent(out) :: rc + character(len=*), parameter :: GRID_SUFFIX = '_grid' + character(len=*), parameter :: FIELD_SUFFIX = '_field' + + type(ESMF_Field) :: field + type(ESMF_Grid) :: grid + integer :: status + + grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) + field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, _RC) + + _RETURN(_SUCCESS) + end function mk_field_common + + elemental function are_almost_equal(x, y) result(almost_equal) + real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) + real(kind=ESMF_KIND_R8), intent(in) :: x + real(kind=ESMF_KIND_R4), intent(in) :: y + logical :: almost_equal + + if(y==0) then + almost_equal = (x==0) + else + almost_equal = (abs(x-y)/abs(y) < EPS) + end if + + end function are_almost_equal + + subroutine initialize_array_R4(x, xmin, xrange) + real(ESMF_KIND_R4), intent(inout) :: x(:,:) + real(ESMF_KIND_R4), intent(in) :: xmin + real(ESMF_KIND_R4), intent(in) :: xrange + integer :: rc + + _ASSERT(xrange > 0, 'Range for random numbers must be positive.') + call random_number(x) + x = xrange * x + xmin + + end subroutine initialize_array_R4 + + subroutine initialize_array_R8(x, xmin, xrange) + real(ESMF_KIND_R8), intent(inout) :: x(:,:) + real(ESMF_KIND_R8), intent(in) :: xmin + real(ESMF_KIND_R8), intent(in) :: xrange + integer :: rc + + _ASSERT(xrange > 0, 'Range for random numbers must be positive.') + call random_number(x) + x = xrange * x + xmin + + end subroutine initialize_array_R8 + +end module geom_setup diff --git a/geom/undo_function_overload.macro b/geom/undo_function_overload.macro new file mode 100644 index 000000000000..2bb42fc3e1f0 --- /dev/null +++ b/geom/undo_function_overload.macro @@ -0,0 +1,5 @@ +#undef _FUNCN +#undef _IDENTITY +#undef _SUB +#undef __SUB +#undef ___SUB From 66dc2b11e9021186fdb7ed2863c5d584e2ff3ccb Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 5 Jun 2023 13:23:39 -0400 Subject: [PATCH 14/93] update changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2caf44c3eeb8..e44d994dc384 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Added field utilities to set a field or field in a state to a constant real number +- Added field utilities to perform arithmetic on fields ### Changed From b655edec6f9c71b9ada6e07c0202d78bb39d2b61 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 5 Jun 2023 13:31:10 -0400 Subject: [PATCH 15/93] add more to public geom --- geom/geom.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/geom/geom.F90 b/geom/geom.F90 index b64c6bafdef6..4b0fc8cfd3b1 100644 --- a/geom/geom.F90 +++ b/geom/geom.F90 @@ -1,4 +1,6 @@ module MAPL_Geom + use MAPL_FieldFunctions + use MAPL_FieldBinaryOperations use MAPL_FieldUtilities use MAPL_FieldPointerUtilities use mapl3g_FieldBlas From 0aa81c65c5f3427b042d380d245eaae014a93bdb Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 5 Jun 2023 15:32:06 -0400 Subject: [PATCH 16/93] fix text so passes with gnu --- geom/tests/Test_FieldBLAS.pf | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 1f7799142192..7cb31c63a202 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -104,6 +104,8 @@ contains x = XR8 y = YR4 + call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) + x_ptr = 4.d0 call FieldCOPY(x, y, _RC) call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) @@ -358,20 +360,6 @@ contains end subroutine test_FieldClone - !elemental function are_almost_equal(x, y) result(almost_equal) - !real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) - !real(kind=ESMF_KIND_R8), intent(in) :: x - !real(kind=ESMF_KIND_R4), intent(in) :: y - !logical :: almost_equal - - !if(y==0) then - !almost_equal = (x==0) - !else - !almost_equal = (abs(x-y)/abs(y) < EPS) - !end if - - !end function are_almost_equal - @Test subroutine test_almost_equal_scalar() character(len=*), parameter :: MSG = 'Difference exceeds threshold' From 6911df6a07382ef5ec634c59ffb9685a8e583a4a Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 5 Jun 2023 15:57:49 -0400 Subject: [PATCH 17/93] gigantic kluge until esmf fixes multi tile getlocalelementcount bug --- geom/FieldPointerUtilities.F90 | 61 ++++++++++++++++++++++++++++++---- 1 file changed, 55 insertions(+), 6 deletions(-) diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 4c67af456596..e4e13af01522 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -317,11 +317,12 @@ function get_local_element_count(x, rc) result(element_count) integer :: status integer :: rank -! element_count = [integer :: ] ! default - call ESMF_FieldGet(x, rank=rank, _RC) allocate(element_count(rank)) - call ESMF_FieldGet(x, localElementCount=element_count, _RC) + ! ESMF has a big fat bug with multi tile grids and loal element count + !call ESMF_FieldGet(x, localElementCount=element_count, _RC) + ! until it is fixed we must kluge :( + call MAPL_FieldGetLocalElementCount(x, element_count, _RC) _RETURN(_SUCCESS) end function get_local_element_count @@ -578,8 +579,56 @@ subroutine copy_r8_r8(cptr_x, cptr_y, n) y_ptr=x_ptr end subroutine copy_r8_r8 - - - +! this procedure must go away as soon as ESMF Fixes their bug + + subroutine MAPL_FieldGetLocalElementCount(field,local_count,rc) + type(ESMF_Field), intent(inout) :: field + integer, allocatable, intent(out) :: local_count(:) + integer, optional, intent(out) :: rc + + integer :: status, rank + type(ESMF_TypeKind_Flag) :: tk + + real(kind=ESMF_KIND_R4), pointer :: r4_1d(:),r4_2d(:,:),r4_3d(:,:,:),r4_4d(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: r8_1d(:),r8_2d(:,:),r8_3d(:,:,:),r8_4d(:,:,:,:) + + call ESMF_FieldGet(field,rank=rank,typekind=tk,_RC) + if (tk == ESMF_TypeKind_R4) then + if (rank==1) then + call ESMF_FieldGet(field,0,farrayptr=r4_1d,_RC) + local_count = shape(r4_1d) + else if (rank ==2) then + call ESMF_FieldGet(field,0,farrayptr=r4_2d,_RC) + local_count = shape(r4_2d) + else if (rank ==3) then + call ESMF_FieldGet(field,0,farrayptr=r4_3d,_RC) + local_count = shape(r4_3d) + else if (rank ==4) then + call ESMF_FieldGet(field,0,farrayptr=r4_4d,_RC) + local_count = shape(r4_4d) + else + _FAIL("Unsupported rank") + end if + else if (tk == ESMF_TypeKind_R8) then + if (rank==1) then + call ESMF_FieldGet(field,0,farrayptr=r8_1d,_RC) + local_count = shape(r8_1d) + else if (rank ==2) then + call ESMF_FieldGet(field,0,farrayptr=r8_2d,_RC) + local_count = shape(r8_2d) + else if (rank ==3) then + call ESMF_FieldGet(field,0,farrayptr=r8_3d,_RC) + local_count = shape(r8_3d) + else if (rank ==4) then + call ESMF_FieldGet(field,0,farrayptr=r8_4d,_RC) + local_count = shape(r8_4d) + else + _FAIL("Unsupported rank") + end if + else + _FAIL("Unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine MAPL_FieldGetLocalElementCount end module From 37bc3649bc55ced2ffad6bca817ecf022b0d51f4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 5 Jun 2023 14:54:38 -0600 Subject: [PATCH 18/93] Add MAPL_StationSamplerMod.F90 --- gridcomps/History/MAPL_StationSamplerMod.F90 | 475 +++++++++++++++++++ 1 file changed, 475 insertions(+) create mode 100644 gridcomps/History/MAPL_StationSamplerMod.F90 diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 new file mode 100644 index 000000000000..f3d5230598c4 --- /dev/null +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -0,0 +1,475 @@ +! Note: content of station_id_file: +! First line: txt +! Second line: [station_id,station_name,lat,lon,elev] +! ... +! +#include "MAPL_Generic.h" +module StationSamplerMod + use ESMF + use MAPL_ErrorHandlingMod + use LocStreamFactoryMod + use pFIO + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_LocstreamRegridderMod + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_c_binding, only: C_NULL_CHAR + implicit none + private + + public :: StationSampler + type :: StationSampler + private + type(LocStreamFactory) :: LSF + type(ESMF_LocStream) :: esmf_ls + type(LocstreamRegridder) :: regridder + integer :: nstation + integer, allocatable :: station_id(:) + character(len=ESMF_MAXSTR), allocatable :: station_name(:) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + real(kind=REAL64), allocatable :: elevs(:) + ! + type(ESMF_FieldBundle) :: bundle + type(FileMetadata) :: fmd + type(NetCDF4_FileFormatter) :: formatter + type(VerticalData) :: vdata + type(TimeData) :: time_info + integer :: obs_written ! replace number_written + character(LEN=ESMF_MAXPATHLEN) :: ofile ! file_name + contains + procedure :: add_metadata_route_handle + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file + procedure :: get_file_start_time + procedure :: compute_time_for_current + procedure :: deallocate_arrays + end type StationSampler + + interface StationSampler + module procedure new_StationSampler_readfile + end interface StationSampler +contains + + + function new_StationSampler_readfile (filename,rc) result(sampler) + use pflogger, only: Logger, logging + type(StationSampler) :: sampler + character(len=*), intent(in) :: filename ! 1:station_name input + integer, optional, intent(out) :: rc + ! loc + character(len=40) :: str, sdmy, shms + integer :: max_len, max_seg, nseg + integer :: unit, ios, nline, id, nstation, status, i, j + integer :: iday, imonth, iyear, ihr, imin, isec + real :: x, y, z, t + character(len=1) :: s1 + type(Logger), pointer :: lgr + + !__ 1. read from station_id_file: static + ! plain text format: [id,name,lat,lon,elev] + ! + open(newunit=unit, file=trim(filename), form='formatted', & + access='sequential', status='old', _IOSTAT) + ios=0 + nstation=0 + do while (ios==0) + read (unit, *, IOSTAT=ios) id, str, x, y, z + if (ios==0) nstation=nstation+1 + end do + sampler%nstation=nstation + allocate(sampler%station_id(nstation)) + allocate(sampler%station_name(nstation)) + allocate(sampler%lons(nstation)) + allocate(sampler%lats(nstation)) + allocate(sampler%elevs(nstation)) + rewind(unit) + do i=1, nstation + read(unit, *) & + sampler%station_id(i), & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + end do + close(unit) + lgr => logging%get_logger('HISTORY.sampler') + call lgr%debug('%a %i8', 'nstation=', nstation) + call lgr%debug('%a %a %a','sampler%station_name(1:2) : ', & + trim(sampler%station_name(1)), trim(sampler%station_name(2))) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& + sampler%lons(1),sampler%lons(2)) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lats(1:2) : ',& + sampler%lats(1),sampler%lats(2)) + + !__ 2. create LocStreamFactory, then esmf_ls including route_handle + ! + sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) + sampler%esmf_ls = sampler%LSF%create_locstream(_RC) + ! + ! init ofile + sampler%ofile='' + sampler%obs_written=0 + _RETURN(_SUCCESS) + end function new_StationSampler_readfile + + + subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_FieldBundle), intent(in) :: bundle + type(TimeData), intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + integer, optional, intent(out) :: rc + ! + integer :: status + type(ESMF_Grid) :: grid + type(ESMF_Clock) :: clock + type(variable) :: v + integer :: fieldCount + integer :: fieldCount_max = 1000 + type(ESMF_Field) :: field + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims + integer :: field_rank, i, nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM), lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + + !__ 1. metadata add_dimension, add_variable for time, latlon, station + ! + this%bundle=bundle + nstation=this%nstation + if (present(vdata)) then + this%vdata=vdata + else + this%vdata=VerticalData(_RC) + end if + call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! take care of lev in fmd + do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then + call this%vdata%get_interpolating_variable(this%bundle,_RC) + endif + call timeInfo%add_time_to_metadata(this%fmd,_RC) ! take care of time in fmd + this%time_info = timeInfo + ! + call this%fmd%add_dimension('station_index',nstation) + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','longitude') + call v%add_attribute('unit','degree_east') + call this%fmd%add_variable('longitude',v) + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','latitude') + call v%add_attribute('unit','degree_north') + call this%fmd%add_variable('latitude',v) + v = Variable(type=pFIO_INT32, dimensions='station_index') + call this%fmd%add_variable('station_id',v) + + !__ 2. filemetadata: extract field from bundle, add_variable + ! + call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + var_name=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(bundle,var_name,field=field,_RC) + call ESMF_FieldGet(field,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = "station_index,time" + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[nstation,1]) + else if (field_rank==3) then + vdims = "lev,station_index,time" + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + ! caution: assume vlevel the same as input-bundle-field/grid + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + end if + call v%add_attribute('units',trim(units)) + call v%add_attribute('long_name',trim(long_name)) + call v%add_attribute('missing_value',MAPL_UNDEF) + call v%add_attribute('_FillValue',MAPL_UNDEF) + call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%fmd%add_variable(trim(var_name),v,_RC) + end do + deallocate (fieldNameList) + + !__ 3. locstream route handle + ! + call ESMF_FieldBundleGet(bundle,grid=grid,_RC) + this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) + _RETURN(_SUCCESS) + end subroutine add_metadata_route_handle + + + subroutine append_file(this,current_time,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + ! + integer :: status + integer :: fieldCount + integer :: ub(1), lb(1) + type(ESMF_Field) :: src_field,dst_field + real(kind=REAL32), allocatable :: p_new_lev(:,:,:) + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + real(kind=REAL32), allocatable :: arr(:,:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: xname + real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i, id, iobs, ix, rank + integer :: nx, nz + + this%obs_written=this%obs_written+1 + + !__ 1. put_var: time variable + ! + rtimes = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%setup_eta_to_pressure(_RC) + end if + if (mapl_am_i_root()) then + call this%formatter%put_var('time',rtimes(1:1),& + start=[this%obs_written],count=[1],_RC) + end if + + !__ 2. put_var: ungridded_dim from src to dst [interpolation] + ! + call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + xname=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(this%bundle,xname,field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname, & + typekind=ESMF_TYPEKIND_R4,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) + if (mapl_am_i_root()) then + call this%formatter%put_var(xname,p_dst_2d,& + start=[1,this%obs_written],count=[this%nstation,1],_RC) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + if (this%vdata%lm/=(ub(1)-lb(1)+1)) then + lb(1)=1 + ub(1)=this%vdata%lm + end if + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname,& + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) + if (mapl_am_i_root()) then + nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx)) + arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) + call this%formatter%put_var(xname,arr,& + start=[1,1,this%obs_written],count=[nz,nx,1],_RC) + !note: lev,station,time + deallocate(arr) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else + _FAIL('grid2LS regridder: rank > 3 not implemented') + end if + end do + deallocate (fieldNameList) + _RETURN(_SUCCESS) + end subroutine append_file + + + subroutine create_file_handle(this,filename,rc) + class(StationSampler), intent(inout) :: this + character(len=*), intent(inout) :: filename ! for ouput nc + integer, optional, intent(out) :: rc + type(variable) :: v + integer :: status + + this%ofile = trim(filename) + v = this%time_info%define_time_variable(_RC) + call this%fmd%modify_variable('time',v,_RC) + this%obs_written = 0 + + if (.not. mapl_am_I_root()) then + _RETURN(_SUCCESS) + end if + call this%formatter%create(trim(filename),_RC) + call this%formatter%write(this%fmd,_RC) + call this%formatter%put_var('longitude',this%lons,_RC) + call this%formatter%put_var('latitude',this%lats,_RC) + call this%formatter%put_var('station_id',this%station_id,_RC) + end subroutine create_file_handle + + + subroutine close_file_handle(this,rc) + class(StationSampler), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + if (trim(this%ofile) /= '') then + if (mapl_am_i_root()) then + call this%formatter%close(_RC) + end if + end if + _RETURN(_SUCCESS) + end subroutine close_file_handle + + + function compute_time_for_current(this,current_time,rc) result(rtimes) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i,status + type(ESMF_TimeInterval) :: tint + type(ESMF_Time) :: file_start_time + character(len=ESMF_MAXSTR) :: tunit + + allocate(rtimes(1),_STAT) + call this%get_file_start_time(file_start_time,tunit,_RC) + tint = current_time-file_start_time + select case(trim(tunit)) + case ('days') + call ESMF_TimeIntervalGet(tint,d_r8=rtimes(1),_RC) + case ('hours') + call ESMF_TimeIntervalGet(tint,h_r8=rtimes(1),_RC) + case ('minutes') + call ESMF_TimeIntervalGet(tint,m_r8=rtimes(1),_RC) + case default + _FAIL('illegal value for tunit: '//trim(tunit)) + end select + _RETURN(_SUCCESS) + end function compute_time_for_current + + + !-- a copy from MAPL_HistoryTrajectoryMod.F90 + ! + subroutine get_file_start_time(this,start_time,time_units,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(inout) :: start_time + character(len=*), intent(inout) :: time_units + integer, optional, intent(out) :: rc + + integer :: status + class(Variable), pointer :: var + type(Attribute), pointer :: attr + class(*), pointer :: pTimeUnits + character(len=ESMF_MAXSTR) :: timeUnits + + integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) + integer strlen + integer firstdash, lastdash + integer firstcolon, lastcolon + integer lastspace,since_pos + integer year,month,day,hour,min,sec + + var => this%fmd%get_variable('time',_RC) + attr => var%get_attribute('units') + ptimeUnits => attr%get_value() + select type(pTimeUnits) + type is (character(*)) + timeUnits = pTimeUnits + strlen = LEN_TRIM (TimeUnits) + + since_pos = index(TimeUnits, 'since') + time_units = trim(TimeUnits(:since_pos-1)) + time_units = trim(time_units) + + firstdash = index(TimeUnits, '-') + lastdash = index(TimeUnits, '-', BACK=.TRUE.) + + if (firstdash .LE. 0 .OR. lastdash .LE. 0) then + if (present(rc)) rc = -1 + return + endif + ypos(2) = firstdash - 1 + mpos(1) = firstdash + 1 + ypos(1) = ypos(2) - 3 + + mpos(2) = lastdash - 1 + dpos(1) = lastdash + 1 + dpos(2) = dpos(1) + 1 + + read ( TimeUnits(ypos(1):ypos(2)), * ) year + read ( TimeUnits(mpos(1):mpos(2)), * ) month + read ( TimeUnits(dpos(1):dpos(2)), * ) day + + firstcolon = index(TimeUnits, ':') + if (firstcolon .LE. 0) then + ! If no colons, check for hour. + ! Logic below assumes a null character or something else is after the hour + ! if we do not find a null character add one so that it correctly parses time + if (TimeUnits(strlen:strlen) /= C_NULL_CHAR) then + TimeUnits = trim(TimeUnits)//C_NULL_CHAR + strlen=len_trim(TimeUnits) + endif + lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) + if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then + hpos(1) = lastspace+1 + hpos(2) = strlen-1 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + min = 0 + sec = 0 + else + hour = 0 + min = 0 + sec = 0 + endif + else + hpos(1) = firstcolon - 2 + hpos(2) = firstcolon - 1 + lastcolon = index(TimeUnits, ':', BACK=.TRUE.) + if ( lastcolon .EQ. firstcolon ) then + mpos(1) = firstcolon + 1 + mpos(2) = firstcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + sec = 0 + else + mpos(1) = firstcolon + 1 + mpos(2) = lastcolon - 1 + spos(1) = lastcolon + 1 + spos(2) = lastcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + read (TimeUnits(spos(1):spos(2)), * ) sec + endif + endif + class default + _FAIL("Time unit must be character") + end select + call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) + _RETURN(_SUCCESS) + end subroutine get_file_start_time + + + subroutine deallocate_arrays (this,rc) + class(StationSampler), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + deallocate(this%station_id) + deallocate(this%station_name) + deallocate(this%lons) + deallocate(this%lats) + deallocate(this%elevs) + _RETURN(_SUCCESS) + end subroutine deallocate_arrays + + +end module StationSamplerMod From 0d2e6c2383a9591dc6145dd1735ebfa6a9fdc96d Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Jun 2023 09:46:04 -0400 Subject: [PATCH 19/93] Move GEOSadas CI build to separate job --- .circleci/config.yml | 40 +++++++++++++++++++++------------------- CHANGELOG.md | 2 ++ 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 278b24dc6ffd..97040cfa92ac 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -148,25 +148,6 @@ workflows: fixture_branch: develop checkout_mapl_branch: true - # Build GEOSadas (ifort only, needs a couple develop branches) - - ci/build: - name: build-GEOSadas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - resource_class: xlarge - baselibs_version: *baselibs_version - repo: GEOSadas - checkout_fixture: true - # This branch on GEOSadas will be used to track subrepos needed - # for GEOSadas + MAPL develop much like how we do with MAPL 3 - #fixture_branch: feature/mathomp4/mapldevelop - checkout_mapl_branch: true - mepodevelop: false - rebuild_procs: 1 - # Run GCM (1 hour, no ExtData) - ci/run_gcm: name: run-GCM-on-<< matrix.compiler >> @@ -218,6 +199,27 @@ workflows: - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version + build-GEOSadas: + jobs: + # Build GEOSadas (ifort only, needs a couple develop branches) + - ci/build: + name: build-GEOSadas-on-<< matrix.compiler >> + context: + - docker-hub-creds + matrix: + parameters: + compiler: [ifort] + resource_class: xlarge + baselibs_version: *baselibs_version + repo: GEOSadas + checkout_fixture: true + # This branch on GEOSadas will be used to track subrepos needed + # for GEOSadas + MAPL develop much like how we do with MAPL 3 + #fixture_branch: feature/mathomp4/mapldevelop + checkout_mapl_branch: true + mepodevelop: false + rebuild_procs: 1 + build-and-publish-docker: when: equal: [ "release", << pipeline.parameters.GHA_Event >> ] diff --git a/CHANGELOG.md b/CHANGELOG.md index e16791fe8a64..e13098b48552 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Make the GEOSadas CI build separate as it often fails due to race conditions in GSI + ### Fixed ### Removed From 77f2fe5f6c88856310528b7458558d7793e8db96 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Jun 2023 10:05:17 -0400 Subject: [PATCH 20/93] Use GEOSadas branch to ignore Held-Suarez --- .circleci/config.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 97040cfa92ac..3aaff1003138 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -213,9 +213,8 @@ workflows: baselibs_version: *baselibs_version repo: GEOSadas checkout_fixture: true - # This branch on GEOSadas will be used to track subrepos needed - # for GEOSadas + MAPL develop much like how we do with MAPL 3 - #fixture_branch: feature/mathomp4/mapldevelop + # Until a fix is in to ignore heldsuarez, we need to use a branch + fixture_branch: feature/mathomp4/ignore-heldsuarez checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 From 0a4a1fbd492cad66179109b3f2de4de2fe9e4e51 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Jun 2023 10:05:57 -0400 Subject: [PATCH 21/93] Fix got into GEOSadas --- .circleci/config.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 3aaff1003138..2eeca25978d7 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -213,8 +213,7 @@ workflows: baselibs_version: *baselibs_version repo: GEOSadas checkout_fixture: true - # Until a fix is in to ignore heldsuarez, we need to use a branch - fixture_branch: feature/mathomp4/ignore-heldsuarez + #fixture_branch: feature/mathomp4/ignore-heldsuarez checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 From f7c984253ab0478459954045dcee4f41f98e2569 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 6 Jun 2023 15:31:46 -0400 Subject: [PATCH 22/93] renamed some stuff... --- geom/{FieldFunctionTemplate.H => FieldUnaryFunctionTemplate.H} | 0 geom/{FieldFunctions.F90 => FieldUnaryFunctions.F90} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename geom/{FieldFunctionTemplate.H => FieldUnaryFunctionTemplate.H} (100%) rename geom/{FieldFunctions.F90 => FieldUnaryFunctions.F90} (100%) diff --git a/geom/FieldFunctionTemplate.H b/geom/FieldUnaryFunctionTemplate.H similarity index 100% rename from geom/FieldFunctionTemplate.H rename to geom/FieldUnaryFunctionTemplate.H diff --git a/geom/FieldFunctions.F90 b/geom/FieldUnaryFunctions.F90 similarity index 100% rename from geom/FieldFunctions.F90 rename to geom/FieldUnaryFunctions.F90 From 2483bf629bb7a66a6915607d627aac5bf5b207e2 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Tue, 6 Jun 2023 15:57:31 -0400 Subject: [PATCH 23/93] move checking to function --- generic/MAPL_Generic.F90 | 52 +++++++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index c8631d1a3b3c..97f59372b40e 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -6068,8 +6068,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) character(len=ESMF_MAXSTR) :: FileType integer :: isNC4 logical :: isPresent - class(AbstractGridFactory), pointer :: app_factory - class (AbstractGridFactory), allocatable :: file_factory character(len=ESMF_MAXSTR) :: grid_type logical :: empty @@ -6306,26 +6304,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_AttributeGet(MPL%GRID%ESMFGRID,'GridType',value=grid_type,rc=status) _VERIFY(status) end if - - block - !note this only works for geos cubed-sphere restarts currently because of - !possible insufficent metadata in the other restarts to support the other grid factories - character(len=:), allocatable :: fname_by_face - logical :: fexist - if (trim(grid_type) == 'Cubed-Sphere') then - app_factory => get_factory(MPL%GRID%ESMFGRID) - ! at this point, arrdes%read_restart_by_face is not initialized - ! pick the first face - fname_by_face = get_fname_by_face(trim(fname), 1) - inquire(FILE = trim(fname_by_face), EXIST=fexist) - if(fexist) then - allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) - else - allocate(file_factory,source=grid_manager%make_factory(trim(fname))) - endif - _ASSERT(file_factory%physical_params_are_equal(app_factory),"Factories not equal") - end if - end block + _ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") call ArrDescrSetNCPar(arrdes,MPL,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) end if PNC4_TILE @@ -6390,6 +6369,35 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) _RETURN(ESMF_SUCCESS) + + contains + function grid_is_consistent(grid_type, fname) result( consistent) + logical :: consistent + character(*), intent(in) :: grid_type + character(*), intent(in) :: fname + !note this only works for geos cubed-sphere restarts currently because of + !possible insufficent metadata in the other restarts to support the other grid factories + class(AbstractGridFactory), pointer :: app_factory + class (AbstractGridFactory), allocatable :: file_factory + character(len=:), allocatable :: fname_by_face + logical :: fexist + + consistent = .True. + if (trim(grid_type) == 'Cubed-Sphere') then + app_factory => get_factory(MPL%GRID%ESMFGRID) + ! at this point, arrdes%read_restart_by_face is not initialized + ! pick the first face + fname_by_face = get_fname_by_face(trim(fname), 1) + inquire(FILE = trim(fname_by_face), EXIST=fexist) + if(fexist) then + allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) + else + allocate(file_factory,source=grid_manager%make_factory(trim(fname))) + endif + consistent = file_factory%physical_params_are_equal(app_factory) + end if + end function + end subroutine MAPL_ESMFStateReadFromFile !============================================================================= From e262d7491b25c0820b57831028bc91865cbba41c Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 11:01:06 -0400 Subject: [PATCH 24/93] reformat a little --- gridcomps/History/CMakeLists.txt | 1 + gridcomps/History/MAPL_StationSamplerMod.F90 | 178 ++++++++++++------- 2 files changed, 114 insertions(+), 65 deletions(-) diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 0973f096f2dc..817da678dded 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -4,6 +4,7 @@ set (srcs MAPL_HistoryTrajectoryMod.F90 MAPL_HistoryCollection.F90 MAPL_HistoryGridComp.F90 + MAPL_StationSamplerMod.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index f3d5230598c4..2f5c5b02423f 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -1,8 +1,13 @@ -! Note: content of station_id_file: -! First line: txt -! Second line: [station_id,station_name,lat,lon,elev] +! Supported station_id_file format +! - choice-A [station_name,lat,lon,elev] +! - choice-B [station_id,station_name,lat,lon,elev] ! ... ! + +! ygyu: add to history.rc +! sampler_type = 'station', 'mask', 'swath' + + #include "MAPL_Generic.h" module StationSamplerMod use ESMF @@ -23,51 +28,54 @@ module StationSamplerMod public :: StationSampler type :: StationSampler private - type(LocStreamFactory) :: LSF - type(ESMF_LocStream) :: esmf_ls + type(LocStreamFactory) :: LSF + type(ESMF_LocStream) :: esmf_ls type(LocstreamRegridder) :: regridder - integer :: nstation + integer :: nstation +!! type(station), allocatable :: integer, allocatable :: station_id(:) character(len=ESMF_MAXSTR), allocatable :: station_name(:) real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: elevs(:) ! - type(ESMF_FieldBundle) :: bundle - type(FileMetadata) :: fmd - type(NetCDF4_FileFormatter) :: formatter - type(VerticalData) :: vdata - type(TimeData) :: time_info - integer :: obs_written ! replace number_written - character(LEN=ESMF_MAXPATHLEN) :: ofile ! file_name + type(ESMF_FieldBundle) :: bundle + type(FileMetadata) :: fmd + type(NetCDF4_FileFormatter) :: formatter + type(VerticalData) :: vdata + type(TimeData) :: time_info + character(LEN=ESMF_MAXPATHLEN) :: ofile + integer :: obs_written contains - procedure :: add_metadata_route_handle - procedure :: create_file_handle - procedure :: close_file_handle - procedure :: append_file - procedure :: get_file_start_time - procedure :: compute_time_for_current - procedure :: deallocate_arrays + procedure :: add_metadata_route_handle + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file + procedure :: get_file_start_time + procedure :: compute_time_for_current + procedure :: deallocate_arrays end type StationSampler interface StationSampler module procedure new_StationSampler_readfile end interface StationSampler -contains +contains function new_StationSampler_readfile (filename,rc) result(sampler) - use pflogger, only: Logger, logging - type(StationSampler) :: sampler - character(len=*), intent(in) :: filename ! 1:station_name input + use pflogger, only : Logger, logging + type(StationSampler) :: sampler + character(len=*), intent(in) :: filename ! 1:station_name input integer, optional, intent(out) :: rc ! loc character(len=40) :: str, sdmy, shms integer :: max_len, max_seg, nseg - integer :: unit, ios, nline, id, nstation, status, i, j + integer :: unit, ios, nline, nstation, status + integer :: i, j, id, ncount integer :: iday, imonth, iyear, ihr, imin, isec - real :: x, y, z, t + real :: x, y, z, t character(len=1) :: s1 + character (len=100) :: line type(Logger), pointer :: lgr !__ 1. read from station_id_file: static @@ -77,8 +85,16 @@ function new_StationSampler_readfile (filename,rc) result(sampler) access='sequential', status='old', _IOSTAT) ios=0 nstation=0 + read(unit, '(a100)', IOSTAT=ios) line + call count_substring(line, ',', ncount) + _ASSERT(ncount.GE.3 .AND. ncount.LE.4, 'wrong input format') + rewind(unit) do while (ios==0) - read (unit, *, IOSTAT=ios) id, str, x, y, z + if(ncount==4) then + read (unit, *, IOSTAT=ios) id, str, x, y, z + elseif (ncount==3) then + read (unit, *, IOSTAT=ios) str, x, y, z + end if if (ios==0) nstation=nstation+1 end do sampler%nstation=nstation @@ -89,16 +105,18 @@ function new_StationSampler_readfile (filename,rc) result(sampler) allocate(sampler%elevs(nstation)) rewind(unit) do i=1, nstation - read(unit, *) & - sampler%station_id(i), & - sampler%station_name(i), & - sampler%lats(i), & - sampler%lons(i) + if(ncount==4) then + read(unit, *) & + sampler%station_id(i), & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + end if end do close(unit) lgr => logging%get_logger('HISTORY.sampler') - call lgr%debug('%a %i8', 'nstation=', nstation) - call lgr%debug('%a %a %a','sampler%station_name(1:2) : ', & + call lgr%debug('%a %i8', 'nstation=', nstation) + call lgr%debug('%a %a %a', 'sampler%station_name(1:2) : ', & trim(sampler%station_name(1)), trim(sampler%station_name(2))) call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& sampler%lons(1),sampler%lons(2)) @@ -107,63 +125,72 @@ function new_StationSampler_readfile (filename,rc) result(sampler) !__ 2. create LocStreamFactory, then esmf_ls including route_handle ! - sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) + sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) sampler%esmf_ls = sampler%LSF%create_locstream(_RC) ! ! init ofile sampler%ofile='' sampler%obs_written=0 + _RETURN(_SUCCESS) end function new_StationSampler_readfile - subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) - class(StationSampler), intent(inout) :: this - type(ESMF_FieldBundle), intent(in) :: bundle - type(TimeData), intent(inout) :: timeInfo + class(StationSampler), intent(inout) :: this + type(ESMF_FieldBundle), intent(in) :: bundle + type(TimeData), intent(inout) :: timeInfo type(VerticalData), optional, intent(inout) :: vdata - integer, optional, intent(out) :: rc - ! - integer :: status - type(ESMF_Grid) :: grid + integer, optional, intent(out) :: rc + + type(variable) :: v + type(ESMF_Grid) :: grid type(ESMF_Clock) :: clock - type(variable) :: v - integer :: fieldCount - integer :: fieldCount_max = 1000 type(ESMF_Field) :: field + integer :: fieldCount + integer :: fieldCount_max = 1000 + integer :: field_rank + integer :: nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM) + integer :: lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + integer :: status + integer :: i + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims - integer :: field_rank, i, nstation - logical :: is_present - integer :: ub(ESMF_MAXDIM), lb(ESMF_MAXDIM) - logical :: do_vertical_regrid - !__ 1. metadata add_dimension, add_variable for time, latlon, station + !__ 1. metadata add_dimension, + ! add_variable for time, latlon, station ! - this%bundle=bundle - nstation=this%nstation + this%bundle = bundle + nstation = this%nstation if (present(vdata)) then - this%vdata=vdata + this%vdata = vdata else - this%vdata=VerticalData(_RC) + this%vdata = VerticalData(_RC) end if - call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! take care of lev in fmd + call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! specify lev in fmd do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then call this%vdata%get_interpolating_variable(this%bundle,_RC) endif - call timeInfo%add_time_to_metadata(this%fmd,_RC) ! take care of time in fmd + + call timeInfo%add_time_to_metadata(this%fmd,_RC) ! specify time in fmd this%time_info = timeInfo - ! + call this%fmd%add_dimension('station_index',nstation) + v = Variable(type=pFIO_REAL32, dimensions='station_index') call v%add_attribute('long_name','longitude') call v%add_attribute('unit','degree_east') call this%fmd%add_variable('longitude',v) + v = Variable(type=pFIO_REAL32, dimensions='station_index') call v%add_attribute('long_name','latitude') call v%add_attribute('unit','degree_north') call this%fmd%add_variable('latitude',v) + v = Variable(type=pFIO_INT32, dimensions='station_index') call this%fmd%add_variable('station_id',v) @@ -197,11 +224,11 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) ! caution: assume vlevel the same as input-bundle-field/grid v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) end if - call v%add_attribute('units',trim(units)) - call v%add_attribute('long_name',trim(long_name)) - call v%add_attribute('missing_value',MAPL_UNDEF) - call v%add_attribute('_FillValue',MAPL_UNDEF) - call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) + call v%add_attribute('units', trim(units)) + call v%add_attribute('long_name', trim(long_name)) + call v%add_attribute('missing_value', MAPL_UNDEF) + call v%add_attribute('_FillValue', MAPL_UNDEF) + call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) call this%fmd%add_variable(trim(var_name),v,_RC) end do deallocate (fieldNameList) @@ -210,10 +237,10 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) ! call ESMF_FieldBundleGet(bundle,grid=grid,_RC) this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) + _RETURN(_SUCCESS) end subroutine add_metadata_route_handle - subroutine append_file(this,current_time,rc) class(StationSampler), intent(inout) :: this type(ESMF_Time), intent(in) :: current_time @@ -246,7 +273,7 @@ subroutine append_file(this,current_time,rc) start=[this%obs_written],count=[1],_RC) end if - !__ 2. put_var: ungridded_dim from src to dst [interpolation] + !__ 2. put_var: ungridded_dim from src to dst [regrid] ! call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) allocate (fieldNameList(fieldCount)) @@ -315,6 +342,8 @@ subroutine create_file_handle(this,filename,rc) call this%formatter%put_var('longitude',this%lons,_RC) call this%formatter%put_var('latitude',this%lats,_RC) call this%formatter%put_var('station_id',this%station_id,_RC) + + _RETURN(_SUCCESS) end subroutine create_file_handle @@ -472,4 +501,23 @@ subroutine deallocate_arrays (this,rc) end subroutine deallocate_arrays + subroutine count_substring (str, t, ncount) + character (len=*), intent(in) :: str + character (len=*), intent(in) :: t + integer, intent(out) :: ncount + integer :: i, j, k, lt + ncount=0 + k=1 + lt = len(t) - 1 + do + i=index(str(k:), t) + !!write(6,*) 'i=', i + !!write(6,*) 'sub string =', trim(str(k:)) + if (i==0) exit + ncount = ncount + 1 + k=k+i+lt + end do + end subroutine count_substring + + end module StationSamplerMod From ce205ab6b7deb6875c206f8a143435602dd37994 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 11:49:17 -0400 Subject: [PATCH 25/93] update --- gridcomps/History/MAPL_HistoryCollection.F90 | 3 +++ gridcomps/History/MAPL_HistoryGridComp.F90 | 23 ++++++++++++++++++++ 2 files changed, 26 insertions(+) diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 4793ef09a3e7..4fb52f8c7cfa 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -9,6 +9,7 @@ module MAPL_HistoryCollectionMod use MAPL_VerticalDataMod use MAPL_TimeDataMod use HistoryTrajectoryMod + use StationSamplerMod use gFTL_StringStringMap implicit none @@ -106,6 +107,8 @@ module MAPL_HistoryCollectionMod logical :: timeseries_output = .false. logical :: recycle_track = .false. type(HistoryTrajectory) :: trajectory + type(StationSampler) :: station_sampler + character(len=ESMF_MAXSTR) :: sampler_spec = "" character(len=ESMF_MAXSTR) :: positive type(HistoryCollectionGlobalAttributes) :: global_atts contains diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 973bbb2c8e75..4206f673d7d9 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -52,11 +52,13 @@ module MAPL_HistoryGridCompMod use MAPL_DownbitMod use pFIO_ConstantsMod use HistoryTrajectoryMod + use StationSamplerMod use MAPL_StringTemplate use regex_module use MAPL_TimeUtilsMod, only: is_valid_time, is_valid_date use gFTL_StringStringMap !use ESMF_CFIOMOD + use pflogger, only: Logger, logging implicit none private @@ -866,6 +868,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if + call ESMF_ConfigGetAttribute(cfg, value=list(n)%sampler_spec, default="", & + label=trim(string) // 'sampler_spec:', _RC) + call ESMF_ConfigGetAttribute(cfg, value=list(n)%stationIdFile, default="", & + label=trim(string) // 'station_id_file:', _RC) + ! Get an optional file containing a 1-D track for the output call ESMF_ConfigGetAttribute(cfg, value=list(n)%trackFile, default="", & label=trim(string) // 'track_file:', _RC) @@ -2363,6 +2370,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%timeseries_output) then list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),_RC) call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) + elseif (list(n)%sampler_spec == 'station') then + list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile),_RC) + call list(n)%station_sampler%add_metadata_route_handle(list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,_RC) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) if (trim(list(n)%output_grid_label)/='') then @@ -3415,6 +3425,15 @@ subroutine Run ( gc, import, export, clock, rc ) list(n)%unit = -1 end if list(n)%currentFile = filename(n) + elseif (list(n)%sampler_spec == 'station') then + if (list(n)%unit.eq.0) then + if (mapl_am_i_root()) call lgr%debug('%a %a',& + "Station_data output to new file:",trim(filename(n))) + call list(n)%station_sampler%close_file_handle(_RC) + call list(n)%station_sampler%create_file_handle(filename(n),_RC) + list(n)%currentFile = filename(n) + list(n)%unit = -1 + end if else if( list(n)%unit.eq.0 ) then if (list(n)%format == 'CFIO') then @@ -3561,6 +3580,10 @@ subroutine Run ( gc, import, export, clock, rc ) call ESMF_ClockGet(clock,currTime=current_time,_RC) call list(n)%trajectory%append_file(current_time,_RC) end if + if (list(n)%sampler_spec == 'station') then + call ESMF_ClockGet(clock,currTime=current_time,_RC) + call list(n)%station_sampler%append_file(current_time,_RC) + endif if( Writing(n) .and. list(n)%unit < 0) then From 80104b05f3076254531a93b99f595ce7f6294947 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 18:56:19 -0400 Subject: [PATCH 26/93] Add logging config in ExtDataDriver --- Tests/ExtDataDriverMod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Tests/ExtDataDriverMod.F90 b/Tests/ExtDataDriverMod.F90 index c4f168d08c85..757398872933 100644 --- a/Tests/ExtDataDriverMod.F90 +++ b/Tests/ExtDataDriverMod.F90 @@ -58,7 +58,9 @@ function newExtDataDriver(name,set_services, unusable, cap_options, rc) result(d driver%cap_options = MAPL_CapOptions() endif call driver%initialize_mpi() - call MAPL_Initialize(comm=MPI_COMM_WORLD,rc=status) + call MAPL_Initialize(comm=MPI_COMM_WORLD, & + logging_config=driver%cap_options%logging_config, & + rc=status) _VERIFY(status) _RETURN(_SUCCESS) end function newExtDataDriver From 61768610f99ce940b6340b22b6d01e6d0af12533 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 18:59:56 -0400 Subject: [PATCH 27/93] . --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9d371f6fd346..dc7b575d25e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.39.3] - 2023-06-07 + +### Add + +- Add logging config to Tests/ExtDataDriverMod.F90 to enable Logger + ## [2.39.2] - 2023-05-30 ### Fixed From 3a0d1206c0f650f06c29d2a7ffafb5a939d04bba Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 19:11:24 -0400 Subject: [PATCH 28/93] update --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dc7b575d25e9..802bf96f6349 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -25,7 +25,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Add -- Add logging config to Tests/ExtDataDriverMod.F90 to enable Logger +- For ExtDataDriver.x only, added logging config to Tests/ExtDataDriverMod.F90 to enable Logger there ## [2.39.2] - 2023-05-30 From f185c113628adedba77caf2a4114a10adf3972cc Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 19:20:54 -0400 Subject: [PATCH 29/93] . --- Tests/ExtDataDriverMod.F90 | 4 +++- gridcomps/History/MAPL_HistoryCollection.F90 | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 2 ++ gridcomps/History/MAPL_StationSamplerMod.F90 | 8 +++++++- 4 files changed, 13 insertions(+), 2 deletions(-) diff --git a/Tests/ExtDataDriverMod.F90 b/Tests/ExtDataDriverMod.F90 index c4f168d08c85..757398872933 100644 --- a/Tests/ExtDataDriverMod.F90 +++ b/Tests/ExtDataDriverMod.F90 @@ -58,7 +58,9 @@ function newExtDataDriver(name,set_services, unusable, cap_options, rc) result(d driver%cap_options = MAPL_CapOptions() endif call driver%initialize_mpi() - call MAPL_Initialize(comm=MPI_COMM_WORLD,rc=status) + call MAPL_Initialize(comm=MPI_COMM_WORLD, & + logging_config=driver%cap_options%logging_config, & + rc=status) _VERIFY(status) _RETURN(_SUCCESS) end function newExtDataDriver diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 4fb52f8c7cfa..13e4daeb1e8a 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -102,6 +102,7 @@ module MAPL_HistoryCollectionMod type(GriddedIOItemVector) :: items character(len=ESMF_MAXSTR) :: currentFile character(len=ESMF_MAXPATHLEN) :: trackFile + character(len=ESMF_MAXPATHLEN) :: stationIdFile logical :: splitField logical :: regex logical :: timeseries_output = .false. diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 4206f673d7d9..cd31929bc6d8 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3211,6 +3211,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! ErrLog vars integer :: status logical :: file_exists + type(Logger), pointer :: lgr !============================================================================= @@ -3416,6 +3417,7 @@ subroutine Run ( gc, import, export, clock, rc ) end if endif + lgr => logging%get_logger('HISTORY.sampler') if (list(n)%timeseries_output) then if (list(n)%unit.eq.0) then if (mapl_am_i_root()) write(6,*)"Sampling to new file: ",trim(filename(n)) diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index 2f5c5b02423f..80b33c67d39f 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -105,12 +105,18 @@ function new_StationSampler_readfile (filename,rc) result(sampler) allocate(sampler%elevs(nstation)) rewind(unit) do i=1, nstation - if(ncount==4) then + if(ncount==4) then read(unit, *) & sampler%station_id(i), & sampler%station_name(i), & sampler%lats(i), & sampler%lons(i) + elseif(ncount==3) then + read(unit, *) & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + sampler%station_id(i)=i end if end do close(unit) From 3a9aab174b2469726463091259c4088c33cc45c8 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 19:24:22 -0400 Subject: [PATCH 30/93] . --- Tests/ExtDataDriverMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/Tests/ExtDataDriverMod.F90 b/Tests/ExtDataDriverMod.F90 index 757398872933..c4f168d08c85 100644 --- a/Tests/ExtDataDriverMod.F90 +++ b/Tests/ExtDataDriverMod.F90 @@ -58,9 +58,7 @@ function newExtDataDriver(name,set_services, unusable, cap_options, rc) result(d driver%cap_options = MAPL_CapOptions() endif call driver%initialize_mpi() - call MAPL_Initialize(comm=MPI_COMM_WORLD, & - logging_config=driver%cap_options%logging_config, & - rc=status) + call MAPL_Initialize(comm=MPI_COMM_WORLD,rc=status) _VERIFY(status) _RETURN(_SUCCESS) end function newExtDataDriver From 8966b1fcd5cb919b17420439cd4a4b55a2ce81b7 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 7 Jun 2023 19:28:31 -0400 Subject: [PATCH 31/93] . --- gridcomps/History/MAPL_StationSamplerMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index 80b33c67d39f..9dcee5a6a832 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -115,7 +115,7 @@ function new_StationSampler_readfile (filename,rc) result(sampler) read(unit, *) & sampler%station_name(i), & sampler%lats(i), & - sampler%lons(i) + sampler%lons(i) sampler%station_id(i)=i end if end do From ea58cfcfba22ad1d7d98fa1cfdfff6fe6998ac31 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 8 Jun 2023 07:56:11 -0400 Subject: [PATCH 32/93] . --- gridcomps/History/MAPL_StationSamplerMod.F90 | 56 ++++++-------------- 1 file changed, 16 insertions(+), 40 deletions(-) diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index 9dcee5a6a832..14e84485ada5 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -1,13 +1,3 @@ -! Supported station_id_file format -! - choice-A [station_name,lat,lon,elev] -! - choice-B [station_id,station_name,lat,lon,elev] -! ... -! - -! ygyu: add to history.rc -! sampler_type = 'station', 'mask', 'swath' - - #include "MAPL_Generic.h" module StationSamplerMod use ESMF @@ -32,13 +22,11 @@ module StationSamplerMod type(ESMF_LocStream) :: esmf_ls type(LocstreamRegridder) :: regridder integer :: nstation -!! type(station), allocatable :: integer, allocatable :: station_id(:) character(len=ESMF_MAXSTR), allocatable :: station_name(:) real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: elevs(:) - ! type(ESMF_FieldBundle) :: bundle type(FileMetadata) :: fmd type(NetCDF4_FileFormatter) :: formatter @@ -53,7 +41,6 @@ module StationSamplerMod procedure :: append_file procedure :: get_file_start_time procedure :: compute_time_for_current - procedure :: deallocate_arrays end type StationSampler interface StationSampler @@ -64,22 +51,21 @@ module StationSamplerMod function new_StationSampler_readfile (filename,rc) result(sampler) use pflogger, only : Logger, logging + implicit none type(StationSampler) :: sampler - character(len=*), intent(in) :: filename ! 1:station_name input + character(len=*), intent(in) :: filename integer, optional, intent(out) :: rc - ! loc + character(len=40) :: str, sdmy, shms - integer :: max_len, max_seg, nseg - integer :: unit, ios, nline, nstation, status + integer :: unit, ios, nstation, status integer :: i, j, id, ncount - integer :: iday, imonth, iyear, ihr, imin, isec - real :: x, y, z, t - character(len=1) :: s1 + real :: x, y, z character (len=100) :: line - type(Logger), pointer :: lgr + type(Logger), pointer :: lgr !__ 1. read from station_id_file: static - ! plain text format: [id,name,lat,lon,elev] + ! plain text format: + ! [name,lat,lon,elev] or [id,name,lat,lon,elev] ! open(newunit=unit, file=trim(filename), form='formatted', & access='sequential', status='old', _IOSTAT) @@ -200,6 +186,11 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) v = Variable(type=pFIO_INT32, dimensions='station_index') call this%fmd%add_variable('station_id',v) + v = Variable(type=pFIO_STRING, dimensions='station_index') + call v%add_attribute('long_name','station_name') + call v%add_attribute('unit','') + call this%fmd%add_variable('station_name',,v) + !__ 2. filemetadata: extract field from bundle, add_variable ! call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) @@ -227,7 +218,6 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) else if (field_rank==3) then vdims = "lev,station_index,time" call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - ! caution: assume vlevel the same as input-bundle-field/grid v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) end if call v%add_attribute('units', trim(units)) @@ -393,8 +383,8 @@ function compute_time_for_current(this,current_time,rc) result(rtimes) end function compute_time_for_current - !-- a copy from MAPL_HistoryTrajectoryMod.F90 - ! + !-- a subroutine from MAPL_HistoryTrajectoryMod.F90 + ! TODO: consolidate with trajectory subroutine get_file_start_time(this,start_time,time_units,rc) class(StationSampler), intent(inout) :: this type(ESMF_Time), intent(inout) :: start_time @@ -494,20 +484,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) end subroutine get_file_start_time - subroutine deallocate_arrays (this,rc) - class(StationSampler), intent(inout) :: this - integer, optional, intent(out) :: rc - integer :: status - deallocate(this%station_id) - deallocate(this%station_name) - deallocate(this%lons) - deallocate(this%lats) - deallocate(this%elevs) - _RETURN(_SUCCESS) - end subroutine deallocate_arrays - - - subroutine count_substring (str, t, ncount) + Subroutine count_substring (str, t, ncount) character (len=*), intent(in) :: str character (len=*), intent(in) :: t integer, intent(out) :: ncount @@ -525,5 +502,4 @@ subroutine count_substring (str, t, ncount) end do end subroutine count_substring - end module StationSamplerMod From cb383604817ec15fb544fae4396e57f6157fc4b4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 8 Jun 2023 08:27:41 -0400 Subject: [PATCH 33/93] station_name put_var to netCDF is commented out. It still needs work. --- gridcomps/History/MAPL_StationSamplerMod.F90 | 52 +++++++++++++++----- 1 file changed, 39 insertions(+), 13 deletions(-) diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index 14e84485ada5..56ed3ccb2ff8 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -60,7 +60,10 @@ function new_StationSampler_readfile (filename,rc) result(sampler) integer :: unit, ios, nstation, status integer :: i, j, id, ncount real :: x, y, z - character (len=100) :: line + logical :: con1, con2 + character (len=1) :: CH1 + character (len=5) :: seq + character (len=100) :: line type(Logger), pointer :: lgr !__ 1. read from station_id_file: static @@ -73,14 +76,29 @@ function new_StationSampler_readfile (filename,rc) result(sampler) nstation=0 read(unit, '(a100)', IOSTAT=ios) line call count_substring(line, ',', ncount) - _ASSERT(ncount.GE.3 .AND. ncount.LE.4, 'wrong input format') + con1= ncount.GE.3 .AND. ncount.LE.4 + _ASSERT(con1, 'string sequence in Aeronet file not supported') + if (ncount==3) then + seq='AFFF' + elseif (ncount==4) then + CH1=line(1:1) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + con2= CH1>='0'.AND.CH1<='9' + if (con1) then + seq='AIFFF' + else + if (con2) then + seq='IAFFF' + else + _ASSERT(.false., 'string sequence in Aeronet file not supported') + end if + end if + end if + rewind(unit) + ios=0 do while (ios==0) - if(ncount==4) then - read (unit, *, IOSTAT=ios) id, str, x, y, z - elseif (ncount==3) then - read (unit, *, IOSTAT=ios) str, x, y, z - end if + read(unit, '(a100)', IOSTAT=ios) line if (ios==0) nstation=nstation+1 end do sampler%nstation=nstation @@ -91,13 +109,19 @@ function new_StationSampler_readfile (filename,rc) result(sampler) allocate(sampler%elevs(nstation)) rewind(unit) do i=1, nstation - if(ncount==4) then + if(seq=='IAFFF') then read(unit, *) & sampler%station_id(i), & sampler%station_name(i), & sampler%lats(i), & sampler%lons(i) - elseif(ncount==3) then + elseif(seq=='AIFFF') then + read(unit, *) & + sampler%station_name(i), & + sampler%station_id(i), & + sampler%lats(i), & + sampler%lons(i) + elseif(trim(seq)=='AFFF') then read(unit, *) & sampler%station_name(i), & sampler%lats(i), & @@ -186,10 +210,11 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) v = Variable(type=pFIO_INT32, dimensions='station_index') call this%fmd%add_variable('station_id',v) - v = Variable(type=pFIO_STRING, dimensions='station_index') - call v%add_attribute('long_name','station_name') - call v%add_attribute('unit','') - call this%fmd%add_variable('station_name',,v) +!! !v = Variable(type=pFIO_STRING, dimensions='station_index') +!! v = Variable(type=pFIO_CHAR, dimensions='station_index') +!! !call v%add_attribute('long_name','station_name') +!! !call v%add_attribute('unit','') +!! call this%fmd%add_variable('station_name',v) !__ 2. filemetadata: extract field from bundle, add_variable ! @@ -338,6 +363,7 @@ subroutine create_file_handle(this,filename,rc) call this%formatter%put_var('longitude',this%lons,_RC) call this%formatter%put_var('latitude',this%lats,_RC) call this%formatter%put_var('station_id',this%station_id,_RC) +!! call this%formatter%put_var('station_name',this%station_name,_RC) _RETURN(_SUCCESS) end subroutine create_file_handle From 42cd72753c36c606600a1883af0ca5c44865a107 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 8 Jun 2023 09:41:59 -0400 Subject: [PATCH 34/93] add CHANGELOG.md --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9d371f6fd346..1da4d17bf2fa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.39.2] - 2023-06-08 + +### Added + +- Add StationSamplerMod for station sampler + ## [2.39.2] - 2023-05-30 ### Fixed From 9df95dd3196fc8ebf88d3acff00153e91acce34e Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 8 Jun 2023 19:01:22 -0400 Subject: [PATCH 35/93] clean up --- gridcomps/History/MAPL_StationSamplerMod.F90 | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 index 56ed3ccb2ff8..0c56b7e7692e 100644 --- a/gridcomps/History/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -210,12 +210,6 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) v = Variable(type=pFIO_INT32, dimensions='station_index') call this%fmd%add_variable('station_id',v) -!! !v = Variable(type=pFIO_STRING, dimensions='station_index') -!! v = Variable(type=pFIO_CHAR, dimensions='station_index') -!! !call v%add_attribute('long_name','station_name') -!! !call v%add_attribute('unit','') -!! call this%fmd%add_variable('station_name',v) - !__ 2. filemetadata: extract field from bundle, add_variable ! call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) @@ -363,7 +357,6 @@ subroutine create_file_handle(this,filename,rc) call this%formatter%put_var('longitude',this%lons,_RC) call this%formatter%put_var('latitude',this%lats,_RC) call this%formatter%put_var('station_id',this%station_id,_RC) -!! call this%formatter%put_var('station_name',this%station_name,_RC) _RETURN(_SUCCESS) end subroutine create_file_handle @@ -509,7 +502,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) _RETURN(_SUCCESS) end subroutine get_file_start_time - + ! TODO: delete and use system utilities when available Subroutine count_substring (str, t, ncount) character (len=*), intent(in) :: str character (len=*), intent(in) :: t @@ -520,8 +513,6 @@ Subroutine count_substring (str, t, ncount) lt = len(t) - 1 do i=index(str(k:), t) - !!write(6,*) 'i=', i - !!write(6,*) 'sub string =', trim(str(k:)) if (i==0) exit ncount = ncount + 1 k=k+i+lt From 4ef5710baa9f493795a29ef0eac7972a9e081bf7 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Fri, 9 Jun 2023 00:00:59 +0000 Subject: [PATCH 36/93] Bump mheap/github-action-required-labels from 4 to 5 Bumps [mheap/github-action-required-labels](https://github.com/mheap/github-action-required-labels) from 4 to 5. - [Release notes](https://github.com/mheap/github-action-required-labels/releases) - [Commits](https://github.com/mheap/github-action-required-labels/compare/v4...v5) --- updated-dependencies: - dependency-name: mheap/github-action-required-labels dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/enforce-labels.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/enforce-labels.yml b/.github/workflows/enforce-labels.yml index 6d4b98633162..86f4bb4e440b 100644 --- a/.github/workflows/enforce-labels.yml +++ b/.github/workflows/enforce-labels.yml @@ -8,7 +8,7 @@ jobs: require-label: runs-on: ubuntu-latest steps: - - uses: mheap/github-action-required-labels@v4 + - uses: mheap/github-action-required-labels@v5 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: @@ -21,7 +21,7 @@ jobs: blocking-label: runs-on: ubuntu-latest steps: - - uses: mheap/github-action-required-labels@v4 + - uses: mheap/github-action-required-labels@v5 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: From c34c728c53ef141655ec4d41c8b9fcde13cc034b Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 9 Jun 2023 11:24:33 -0400 Subject: [PATCH 37/93] lots of updates remove undef from interface, make in/out rather than in place --- geom/CMakeLists.txt | 2 +- geom/FieldBinaryOperatorTemplate.H | 47 +++++-- geom/FieldPointerUtilities.F90 | 219 ++++++++++++++++++++++++++++- geom/FieldUnaryFunctionTemplate.H | 59 +++++--- geom/FieldUnaryFunctions.F90 | 32 ++--- geom/FieldUtilities.F90 | 80 +++++++---- geom/geom.F90 | 2 +- geom/tests/Test_FieldArithmetic.pf | 37 +++-- geom/tests/geom_setup.F90 | 5 + 9 files changed, 396 insertions(+), 87 deletions(-) diff --git a/geom/CMakeLists.txt b/geom/CMakeLists.txt index 21098a08a5b4..d61a49483989 100644 --- a/geom/CMakeLists.txt +++ b/geom/CMakeLists.txt @@ -15,7 +15,7 @@ set(srcs FieldBLAS.F90 FieldPointerUtilities.F90 FieldUtilities.F90 - FieldFunctions.F90 + FieldUnaryFunctions.F90 FieldBinaryOperations.F90 ) # Workaround for strict NAG Fortran with ESMF implicit interface for private state. diff --git a/geom/FieldBinaryOperatorTemplate.H b/geom/FieldBinaryOperatorTemplate.H index 8f9f6e79d9e1..4bae5cc5fb03 100644 --- a/geom/FieldBinaryOperatorTemplate.H +++ b/geom/FieldBinaryOperatorTemplate.H @@ -1,30 +1,47 @@ #define _NAME field #include "function_overload.macro" - subroutine _SUB(field_a,field_b,undef,rc) + subroutine _SUB(field_out,field_a,field_b,rc) + type(ESMF_Field), intent(inout) :: field_out type(ESMF_Field), intent(inout) :: field_a type(ESMF_Field), intent(inout) :: field_b - real, optional, intent(in) :: undef integer, optional, intent(out) :: rc integer :: status - type(ESMF_TypeKind_Flag) :: tk_a,tk_b + type(ESMF_TypeKind_Flag) :: tk_a,tk_b,tk_out + logical :: has_undef,conformable + type(ESMF_Field) :: fields(3) + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + real(kind=ESMF_KIND_R4), pointer :: ptr1_r4(:), ptr2_r4(:), ptr_out_r4(:) + real(kind=ESMF_KIND_R8), pointer :: ptr1_r8(:), ptr2_r8(:), ptr_out_r8(:) - real(kind=ESMF_KIND_R4), pointer :: ptr1_r4(:), ptr2_r4(:) - real(kind=ESMF_KIND_R8), pointer :: ptr1_r8(:), ptr2_r8(:) + fields(1)=field_a + fields(2)=field_b + fields(3)=field_out + conformable = FieldsAreConformable(field_a,field_out,_RC) + _ASSERT(conformable,"Fields passed binary operator are not conformable") + conformable = FieldsAreConformable(field_b,field_out,_RC) + _ASSERT(conformable,"Fields passed binary operator are not conformable") + has_undef = FieldsHaveUndef(fields,_RC) call ESMF_FieldGet(field_a,typekind=tk_a,_RC) call ESMF_FieldGet(field_b,typekind=tk_b,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + + _ASSERT(tk_a==tk_out, "For now we will only allow operations on same type fields") + _ASSERT(tk_b==tk_out, "For now we will only allow operations on same type fields") - _ASSERT(tk_a==tk_b, "For now we will only allow operations on same type fields") if (tk_a ==ESMF_TypeKind_R4) then call assign_fptr(field_a,ptr1_r4,_RC) call assign_fptr(field_b,ptr2_r4,_RC) - if (present(undef)) then - where( (ptr1_r4 /= undef) .and. (ptr2_r4 /= undef) ) + call assign_fptr(field_out,ptr_out_r4,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where( (ptr1_r4 /= undef_r4(1)) .and. (ptr2_r4 /= undef_r4(2)) ) ptr1_r4 = ptr1_r4 _OP ptr2_r4 - else where - ptr1_r4 = undef + elsewhere + ptr1_r4 = undef_r4(3) end where else ptr1_r4 = ptr1_r4 _OP ptr2_r4 @@ -32,12 +49,14 @@ else if (tk_A == ESMF_TypeKind_R8) then call assign_fptr(field_a,ptr1_r8,_RC) call assign_fptr(field_b,ptr2_r8,_RC) - if (present(undef)) then - where( (ptr1_r8 /= undef) .and. (ptr2_r8 /= undef) ) + call assign_fptr(field_out,ptr_out_r8,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where( (ptr1_r8 /= undef_r8(1)) .and. (ptr2_r8 /= undef_r8(2)) ) ptr1_r8 = ptr1_r8 _OP ptr2_r8 else where - ptr1_r8 = undef - end where + ptr1_r8 = undef_r8(3) + endwhere else ptr1_r8 = ptr1_r8 _OP ptr2_r8 end if diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index e4e13af01522..4e40762e6172 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -8,14 +8,23 @@ module MAPL_FieldPointerUtilities implicit none private + public :: FieldsHaveUndef + public :: GetFieldsUndef public :: assign_fptr public :: FieldGetLocalElementCount public :: FieldGetLocalSize public :: FieldGetCptr public :: FieldClone public :: FieldsAreConformable + public :: FieldsAreBroadcastConformable public :: FieldsAreSameTypeKind public :: FieldCopy + public :: FieldCopyBroadcast + + interface GetFieldsUndef + module procedure GetFieldsUndef_r4 + module procedure GetFieldsUndef_r8 + end interface interface assign_fptr module procedure assign_fptr_r4_rank1 @@ -41,6 +50,10 @@ module MAPL_FieldPointerUtilities procedure are_conformable_array end interface + interface FieldsAreBroadCastConformable + procedure are_broadcast_conformable + end interface + interface FieldClone module procedure clone end interface FieldClone @@ -54,11 +67,13 @@ module MAPL_FieldPointerUtilities module procedure verify_typekind_array end interface verify_typekind - ! call FieldCOPY(x, ddy, rc): y = x interface FieldCOPY procedure copy end interface FieldCOPY + interface FieldCopyBroadcast + procedure copy_broadcast + end interface FieldCopyBroadcast contains @@ -417,6 +432,32 @@ logical function are_conformable_array(x, y, rc) result(conformable) _RETURN(_SUCCESS) end function are_conformable_array + logical function are_broadcast_conformable(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + integer :: rank_x, rank_y + integer, dimension(:), allocatable :: count_x, count_y + integer :: status + + ! this should really used the geom and ungridded dims + ! for now we will do this until we have a geom agnostic stuff worked out... + ! the ideal algorithm would be if geom == geom and input does not have ungridded + ! and thing we are copying to does, then we are "conformable" + conformable = .false. + + call ESMF_FieldGet(x, rank=rank_x, _RC) + call ESMF_FieldGet(y, rank=rank_y, _RC) + + if( (rank_x+1) == rank_y) then + count_x = FieldGetLocalElementCount(x, _RC) + count_y = FieldGetLocalElementCount(y, _RC) + conformable = all(count_x == count_y(:rank_y-1)) + end if + + _RETURN(_SUCCESS) + end function are_broadcast_conformable + logical function are_same_type_kind(x, y, rc) result(same_tk) type(ESMF_Field), intent(inout) :: x type(ESMF_Field), intent(inout) :: y @@ -477,6 +518,132 @@ function is_valid_typekind(actual_tk, valid_tks) result(is_valid) end function is_valid_typekind + subroutine copy_broadcast(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + type(c_ptr) :: cptr_x, cptr_y + integer(kind=ESMF_KIND_I8) :: n_input,n_extra + integer :: status + logical :: conformable, broadcast + integer, allocatable :: x_shape(:), y_shape(:) + logical :: x_is_double + logical :: y_is_double + character(len=*), parameter :: UNSUPPORTED_TK = & + 'Unsupported typekind in FieldCOPY() for ' + + conformable = FieldsAreConformable(x, y) + if (conformable) then + call copy(x,y,_RC) + _RETURN(_SUCCESS) + end if + broadcast = FieldsAreBroadcastConformable(x,y) + _ASSERT(broadcast, 'FieldCopy() - fields not be broadcast.') + + call MAPL_FieldGetLocalElementCount(x,x_shape,_RC) + call MAPL_FieldGetLocalElementCount(y,y_shape,_RC) + call FieldGetCptr(x, cptr_x, _RC) + call ESMF_FieldGet(x, typekind = tk_x, _RC) + + n_input = product(x_shape) + n_extra = y_shape(size(y_shape)) + + call FieldGetCptr(y, cptr_y, _RC) + call ESMF_FieldGet(y, typekind = tk_y, _RC) + + y_is_double = (tk_y == ESMF_TYPEKIND_R8) + _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') + + x_is_double = (tk_x == ESMF_TYPEKIND_R8) + _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') + + if (y_is_double) then + if (x_is_double) then + call copy_bcast_r8_r8(cptr_x, cptr_y, n_input,n_extra) + else + call copy_bcast_r4_r8(cptr_x, cptr_y, n_input,n_extra) + end if + else + if (x_is_double) then + call copy_bcast_r8_r4(cptr_x, cptr_y, n_input,n_extra) + else + call copy_bcast_r4_r4(cptr_x, cptr_y, n_input,n_extra) + end if + end if + + _RETURN(_SUCCESS) + end subroutine copy_broadcast + + subroutine copy_bcast_r4_r4(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r4_r4 + + subroutine copy_bcast_r4_r8(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r4_r8 + + subroutine copy_bcast_r8_r4(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r8_r4 + + subroutine copy_bcast_r8_r8(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r8_r8 + subroutine copy(x, y, rc) type(ESMF_Field), intent(inout) :: x type(ESMF_Field), intent(inout) :: y @@ -631,4 +798,54 @@ subroutine MAPL_FieldGetLocalElementCount(field,local_count,rc) _RETURN(_SUCCESS) end subroutine MAPL_FieldGetLocalElementCount + function FieldsHaveUndef(fields,rc) result(all_have_undef) + logical :: all_have_undef + type(ESMF_Field), intent(inout) :: fields(:) + integer, optional, intent(out) :: rc + + integer :: status, i + logical :: isPresent + + all_have_undef = .true. + do i =1,size(fields) + call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) + all_have_undef = (all_have_undef .and. isPresent) + enddo + _RETURN(_SUCCESS) + end function + + subroutine GetFieldsUndef_r4(fields,undef_values,rc) + type(ESMF_Field), intent(inout) :: fields(:) + real(kind=ESMF_KIND_R4), allocatable,intent(inout) :: undef_values(:) + integer, optional, intent(out) :: rc + + integer :: status, i + logical :: isPresent + + allocate(undef_values(size(fields))) + do i =1,size(fields) + call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) + _ASSERT(isPresent,"missing undef value") + call ESMF_AttributeGet(fields(i),value=undef_values(i),name="missing_value",_RC) + enddo + _RETURN(_SUCCESS) + end subroutine GetFieldsUndef_r4 + + subroutine GetFieldsUndef_r8(fields,undef_values,rc) + type(ESMF_Field), intent(inout) :: fields(:) + real(kind=ESMF_KIND_R8), allocatable,intent(inout) :: undef_values(:) + integer, optional, intent(out) :: rc + + integer :: status, i + logical :: isPresent + + allocate(undef_values(size(fields))) + do i =1,size(fields) + call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) + _ASSERT(isPresent,"missing undef value") + call ESMF_AttributeGet(fields(i),value=undef_values(i),name="missing_value",_RC) + enddo + _RETURN(_SUCCESS) + end subroutine GetFieldsUndef_r8 + end module diff --git a/geom/FieldUnaryFunctionTemplate.H b/geom/FieldUnaryFunctionTemplate.H index 0c0af6fd7e75..b820c33f1c32 100644 --- a/geom/FieldUnaryFunctionTemplate.H +++ b/geom/FieldUnaryFunctionTemplate.H @@ -1,35 +1,54 @@ #define _NAME field #include "function_overload.macro" - subroutine _SUB(field,undef,rc) - type(ESMF_Field), intent(inout) :: field - real, optional, intent(in) :: undef + subroutine _SUB(field_out,field_in,rc) + type(ESMF_Field), intent(inout) :: field_out + type(ESMF_Field), intent(inout) :: field_in integer, optional, intent(out) :: rc integer :: status - type(ESMF_TypeKind_Flag) :: tk + type(ESMF_Field) :: fields(2) + type(ESMF_TypeKind_Flag) :: tk_in, tk_out + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + real(kind=ESMF_KIND_R4), pointer :: ptr_r4_in(:),ptr_r4_out(:) + real(kind=ESMF_KIND_R8), pointer :: ptr_r8_in(:),ptr_r8_out(:) + logical :: has_undef, conformable + + conformable = FieldsAreConformable(field_in,field_out,_RC) + _ASSERT(conformable,"Fields passed unary function are not conformable") - real(kind=ESMF_KIND_R4), pointer :: ptr_r4(:) - real(kind=ESMF_KIND_R8), pointer :: ptr_r8(:) - - call ESMF_FieldGet(field,typekind=tk,_RC) - if (tk ==ESMF_TypeKind_R4) then - call assign_fptr(field,ptr_r4,_RC) - if (present(undef)) then - where(ptr_r4 /= undef) - ptr_r4 = _FUNC(ptr_r4) + fields(1) = field_in + fields(2) = field_out + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field_in,typekind=tk_in,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + _ASSERT(tk_in == tk_out, "For now input and output field must be of same type for a field function") + if (tk_in ==ESMF_TypeKind_R4) then + call assign_fptr(field_in,ptr_r4_in,_RC) + call assign_fptr(field_out,ptr_r4_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(ptr_r4_in /= undef_r4(1)) + ptr_r4_out = _FUNC(ptr_r4_in) + elsewhere + ptr_r4_out = undef_r4(2) end where else - ptr_r4 = _FUNC(ptr_r4) + ptr_r4_out = _FUNC(ptr_r4_in) end if - else if (tk == ESMF_TypeKind_R8) then - call assign_fptr(field,ptr_r8,_RC) - if (present(undef)) then - where(ptr_r8 /= undef) - ptr_r8 = _FUNC(ptr_r4) + else if (tk_in == ESMF_TypeKind_R8) then + call assign_fptr(field_in,ptr_r8_in,_RC) + call assign_fptr(field_out,ptr_r8_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(ptr_r8_in /= undef_r8(1)) + ptr_r8_out = _FUNC(ptr_r8_in) + elsewhere + ptr_r4_out = undef_r8(2) end where else - ptr_r8 = _FUNC(ptr_r8) + ptr_r8_out = _FUNC(ptr_r8_in) end if else _FAIL("unsupported type") diff --git a/geom/FieldUnaryFunctions.F90 b/geom/FieldUnaryFunctions.F90 index 2cd13a72cfdd..1cba7b968c3f 100644 --- a/geom/FieldUnaryFunctions.F90 +++ b/geom/FieldUnaryFunctions.F90 @@ -1,6 +1,6 @@ #include "MAPL_Generic.h" -module MAPL_FieldFunctions +module MAPL_FieldUnaryFunctions use ESMF use MAPL_ExceptionHandling use MAPL_FieldPointerUtilities @@ -26,60 +26,60 @@ module MAPL_FieldFunctions contains #define _FUNC Abs -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Exp -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Log10 -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Log -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Sqrt -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Sinh -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Cosh -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Tanh -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Sin -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Cos -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Tan -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Asin -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Acos -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC #define _FUNC Atan -#include "FieldFunctionTemplate.H" +#include "FieldUnaryFunctionTemplate.H" #undef _FUNC -end module MAPL_FieldFunctions +end module MAPL_FieldUnaryFunctions diff --git a/geom/FieldUtilities.F90 b/geom/FieldUtilities.F90 index 45b423def7f7..130d09222f8e 100644 --- a/geom/FieldUtilities.F90 +++ b/geom/FieldUtilities.F90 @@ -96,21 +96,28 @@ subroutine FieldSet_r4(field,constant_val,rc) _RETURN(ESMF_SUCCESS) end subroutine FieldSet_r4 -subroutine FieldNegate(field,undef,rc) +subroutine FieldNegate(field,rc) type(ESMF_Field), intent(inout) :: field - real, optional, intent(in) :: undef integer, intent(out), optional :: rc type(ESMF_TYPEKIND_FLAG) :: type_kind real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + logical :: has_undef + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) integer :: status + type(ESMF_Field) :: fields(1) + + fields(1) = field + has_undef = FieldsHaveUndef(fields,_RC) call ESMF_FieldGet(field,typekind=type_kind,_RC) if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r4,_RC) - if (present(undef)) then - where(f_ptr_r4 /= undef) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(f_ptr_r4 /= undef_r4(1)) f_ptr_r4 = -f_ptr_r4 end where else @@ -118,8 +125,9 @@ subroutine FieldNegate(field,undef,rc) end if else if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r8,_RC) - if (present(undef)) then - where(f_ptr_r8 /= undef) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(f_ptr_r8 /= undef_r8(1)) f_ptr_r8 = -f_ptr_r8 end where else @@ -131,35 +139,55 @@ subroutine FieldNegate(field,undef,rc) _RETURN(ESMF_SUCCESS) end subroutine FieldNegate -subroutine FieldPow(field,expo,undef,rc) - type(ESMF_Field), intent(inout) :: field +subroutine FieldPow(field_out,field_in,expo,rc) + type(ESMF_Field), intent(inout) :: field_out + type(ESMF_Field), intent(inout) :: field_in real, intent(in) :: expo - real, optional, intent(in) :: undef integer, intent(out), optional :: rc - type(ESMF_TYPEKIND_FLAG) :: type_kind - real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) - real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + type(ESMF_TypeKind_Flag) :: tk_in, tk_out + real(kind=ESMF_KIND_R4), pointer :: ptr_r4_in(:),ptr_r4_out(:) + real(kind=ESMF_KIND_R8), pointer :: ptr_r8_in(:),ptr_r8_out(:) integer :: status - - call ESMF_FieldGet(field,typekind=type_kind,_RC) - if (type_kind == ESMF_TYPEKIND_R4) then - call assign_fptr(field,f_ptr_r4,_RC) - if (present(undef)) then - where(f_ptr_r4 /= undef) - f_ptr_r4 = f_ptr_r4 ** expo + logical :: has_undef,conformable + type(ESMF_Field) :: fields(2) + + conformable = FieldsAreConformable(field_in,field_out,_RC) + _ASSERT(conformable,"Fields passed power function are not conformable") + + fields(1) = field_in + fields(2) = field_out + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field_in,typekind=tk_in,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + _ASSERT(tk_in == tk_out, "For now input and output field must be of same type for a field function") + if (tk_in == ESMF_TYPEKIND_R4) then + call assign_fptr(field_in,ptr_r4_in,_RC) + call assign_fptr(field_out,ptr_r4_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(ptr_r4_in /= undef_r4(1)) + ptr_r4_out = ptr_r4_in**expo + elsewhere + ptr_r4_out = undef_r4(2) end where else - f_ptr_r4 = f_ptr_r4**expo + ptr_r4_out = ptr_r4_in**expo end if - else if (type_kind == ESMF_TYPEKIND_R4) then - call assign_fptr(field,f_ptr_r8,_RC) - if (present(undef)) then - where(f_ptr_r8 /= undef) - f_ptr_r8 = f_ptr_r8 ** expo + else if (tk_in == ESMF_TYPEKIND_R8) then + call assign_fptr(field_in,ptr_r8_in,_RC) + call assign_fptr(field_out,ptr_r8_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(ptr_r8_in /= undef_r8(1)) + ptr_r8_out = ptr_r8_in**expo + elsewhere + ptr_r8_out = undef_r8(2) end where else - f_ptr_r8 = f_ptr_r8**expo + ptr_r8_out = ptr_r8_in**expo end if else _FAIL('unsupported typekind') diff --git a/geom/geom.F90 b/geom/geom.F90 index 4b0fc8cfd3b1..93a803c892d4 100644 --- a/geom/geom.F90 +++ b/geom/geom.F90 @@ -1,5 +1,5 @@ module MAPL_Geom - use MAPL_FieldFunctions + use MAPL_FieldUnaryFunctions use MAPL_FieldBinaryOperations use MAPL_FieldUtilities use MAPL_FieldPointerUtilities diff --git a/geom/tests/Test_FieldArithmetic.pf b/geom/tests/Test_FieldArithmetic.pf index afaa1cebe929..84d63e1c6f61 100644 --- a/geom/tests/Test_FieldArithmetic.pf +++ b/geom/tests/Test_FieldArithmetic.pf @@ -3,7 +3,7 @@ module Test_FieldArithmetic use geom_setup - use MAPL_FieldFunctions + use MAPL_FieldUnaryFunctions use MAPL_FieldBinaryOperations use MAPL_FieldUtilities use MAPL_FieldPointerUtilities @@ -38,6 +38,10 @@ contains indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + call ESMF_AttributeSet(xr4,name="missing_value",value=undef,_RC) + call ESMF_AttributeSet(xr8,name="missing_value",value=undef,_RC) + call ESMF_AttributeSet(yr4,name="missing_value",value=undef,_RC) + call ESMF_AttributeSet(yr8,name="missing_value",value=undef,_RC) end subroutine set_up_data @@ -58,7 +62,7 @@ contains y_ptr = 3.0 result_array = x_ptr result_array = 5.0 - call FieldAdd(x, y, _RC) + call FieldAdd(x, x, y, _RC) @assertEqual(x_ptr, result_array) end subroutine test_FieldAddR4 @@ -69,11 +73,9 @@ contains real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) integer :: status, rc - real :: undef x = XR4 y = YR4 - undef = 42.0 call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) @@ -81,7 +83,7 @@ contains y_ptr = reshape(source=[undef,3.0,3.0,undef],shape=[2,2]) result_array = x_ptr result_array = reshape(source=[undef,5.0,5.0,undef],shape=[2,2]) - call FieldAdd(x, y, undef=undef, _RC) + call FieldAdd(x, x, y, _RC) @assertEqual(x_ptr, result_array) end subroutine test_FieldAddR4_missing @@ -102,7 +104,7 @@ contains y_ptr = 3.d0 result_array = x_ptr result_array = 5.d0 - call FieldAdd(x, y, _RC) + call FieldAdd(x, x, y, _RC) @assertEqual(x_ptr, result_array) end subroutine test_FieldAddR8 @@ -121,10 +123,29 @@ contains expo = 4.0 result_array = x_ptr result_array = 2.0**expo - call FieldPow(x, expo, _RC) + call FieldPow(x, x, expo, _RC) @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR4 + @Test + subroutine test_FieldPowR8() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) + integer :: status, rc + real :: expo + + x = XR8 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.d0 + expo = 4.0 + result_array = x_ptr + result_array = 2.d0**expo + call FieldPow(x, x, expo, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldPowR8 + @Test subroutine test_FieldSinR4() type(ESMF_Field) :: x @@ -138,7 +159,7 @@ contains x_ptr = 2.0 result_array = x_ptr result_array = sin(2.0) - call FieldSin(x, _RC) + call FieldSin(x, x, _RC) @assertEqual(x_ptr, result_array) end subroutine test_FieldSinR4 diff --git a/geom/tests/geom_setup.F90 b/geom/tests/geom_setup.F90 index 0302fcbb38c0..957925beca16 100644 --- a/geom/tests/geom_setup.F90 +++ b/geom/tests/geom_setup.F90 @@ -27,6 +27,7 @@ module geom_setup integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] integer, parameter :: SIZE_R4 = 16 integer, parameter :: SIZE_R8 = 16 + real, parameter :: undef = 42.0 real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R4)], DIMR4_DEFAULT) real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R8)], DIMR8_DEFAULT) @@ -35,6 +36,10 @@ module geom_setup type(ESMF_Field) :: XR8 type(ESMF_Field) :: YR4 type(ESMF_Field) :: YR8 + type(ESMF_Field) :: XR4_3D + type(ESMF_Field) :: XR8_3D + type(ESMF_Field) :: YR4_3D + type(ESMF_Field) :: YR8_3D contains From f697cb3983a06fcda0f60516bf319c013aa75de5 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 9 Jun 2023 12:19:05 -0400 Subject: [PATCH 38/93] Update CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 57082652fcbb..5263070c7180 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Added field utilities to perform arithmetic on fields +- Added field utilities to perform basic numeric operations on fields ### Changed From 7f4f2d80152c5a020a9e9d5b3bcc503381a1b9f4 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 9 Jun 2023 18:55:43 -0400 Subject: [PATCH 39/93] add ReplaceMetadata message and method for pfio --- CHANGELOG.md | 1 + pfio/AbstractMessage.F90 | 2 + pfio/CMakeLists.txt | 1 + pfio/ClientManager.F90 | 36 +++++++++++++ pfio/ClientThread.F90 | 20 +++++++ pfio/HistoryCollection.F90 | 14 +++++ pfio/MessageVisitor.F90 | 15 ++++++ pfio/ProtocolParser.F90 | 4 ++ pfio/ReplaceMetadataMessage.F90 | 95 +++++++++++++++++++++++++++++++++ pfio/ServerThread.F90 | 21 ++++++++ 10 files changed, 209 insertions(+) create mode 100644 pfio/ReplaceMetadataMessage.F90 diff --git a/CHANGELOG.md b/CHANGELOG.md index 5263070c7180..c19a55cff831 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added ReplaceMetadata message and method to replace oserver's metadata - Added field utilities to perform basic numeric operations on fields ### Changed diff --git a/pfio/AbstractMessage.F90 b/pfio/AbstractMessage.F90 index 8927c3f0552e..44fc56d6ccd4 100644 --- a/pfio/AbstractMessage.F90 +++ b/pfio/AbstractMessage.F90 @@ -23,6 +23,7 @@ module pFIO_AbstractMessageMod public :: COLLECTIVEPrefetchData_ID public :: COLLECTIVEStageData_ID public :: ModifyMetadata_ID + public :: ReplaceMetadata_ID public :: HandShake_ID public :: DUMMY_ID public :: ForwardData_ID @@ -42,6 +43,7 @@ module pFIO_AbstractMessageMod enumerator :: StageData_ID enumerator :: COLLECTIVEStageData_ID enumerator :: ModifyMetadata_ID + enumerator :: ReplaceMetadata_ID enumerator :: HandShake_ID enumerator :: DUMMY_ID enumerator :: ForwardData_ID diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index ce62f5fe841c..01f0ff3c8137 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -46,6 +46,7 @@ set (srcs CollectiveStageDataMessage.F90 AddHistCollectionMessage.F90 ModifyMetadataMessage.F90 + ReplaceMetadataMessage.F90 ForwardDataAndMessage.F90 ForwardDataMessage.F90 ProtocolParser.F90 diff --git a/pfio/ClientManager.F90 b/pfio/ClientManager.F90 index fc19ebadb6b6..a572d8443c3a 100644 --- a/pfio/ClientManager.F90 +++ b/pfio/ClientManager.F90 @@ -39,7 +39,9 @@ module pFIO_ClientManagerMod procedure :: add_ext_collection procedure :: add_hist_collection procedure :: modify_metadata + procedure :: replace_metadata procedure :: modify_metadata_all + procedure :: replace_metadata_all procedure :: prefetch_data procedure :: stage_data procedure :: collective_prefetch_data @@ -187,6 +189,22 @@ subroutine modify_metadata(this, collection_id, unusable,var_map, rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata + subroutine replace_metadata(this, collection_id, fmd, rc) + class (ClientManager), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (ClientThread), pointer :: clientPtr + integer :: status + + ClientPtr => this%current() + call clientPtr%replace_metadata(collection_id, fmd, rc=status) + _VERIFY(status) + + _RETURN(_SUCCESS) + end subroutine replace_metadata + subroutine modify_metadata_all(this, collection_id, unusable,var_map,rc) class (ClientManager), intent(inout) :: this integer, intent(in) :: collection_id @@ -207,6 +225,24 @@ subroutine modify_metadata_all(this, collection_id, unusable,var_map,rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata_all + subroutine replace_metadata_all(this, collection_id, fmd, rc) + class (ClientManager), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (ClientThread), pointer :: clientPtr + integer :: i, status + + do i = 1, this%clients%size() + ClientPtr => this%clients%at(i) + call clientPtr%replace_metadata(collection_id, fmd, rc=status) + _VERIFY(status) + enddo + + _RETURN(_SUCCESS) + end subroutine replace_metadata_all + subroutine collective_prefetch_data(this, collection_id, file_name, var_name, data_reference, & & unusable, start,global_start,global_count, rc) class (ClientManager), intent(inout) :: this diff --git a/pfio/ClientThread.F90 b/pfio/ClientThread.F90 index 0a302bb552e1..f8e3c0491c6b 100644 --- a/pfio/ClientThread.F90 +++ b/pfio/ClientThread.F90 @@ -30,6 +30,7 @@ module pFIO_ClientThreadMod use pFIO_CollectivePrefetchDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_StringVariableMapMod use, intrinsic :: iso_fortran_env, only: REAL32 @@ -57,6 +58,7 @@ module pFIO_ClientThreadMod procedure :: add_ext_collection procedure :: add_hist_collection procedure :: modify_metadata + procedure :: replace_metadata procedure :: prefetch_data procedure :: stage_data procedure :: collective_prefetch_data @@ -209,6 +211,24 @@ subroutine modify_metadata(this, collection_id, unusable,var_map, rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata + subroutine replace_metadata(this, collection_id, fmd, rc) + class (ClientThread), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata),intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (AbstractMessage), pointer :: handshake_msg + class(AbstractSocket),pointer :: connection + integer :: status + + connection=>this%get_connection() + call connection%send(ReplaceMetadataMessage(collection_id,fmd),_RC) + + handshake_msg => connection%receive() + deallocate(handshake_msg) + _RETURN(_SUCCESS) + end subroutine replace_metadata + function collective_prefetch_data(this, collection_id, file_name, var_name, data_reference, & & unusable, start,global_start,global_count, rc) result(request_id) class (ClientThread), intent(inout) :: this diff --git a/pfio/HistoryCollection.F90 b/pfio/HistoryCollection.F90 index d42143112ca0..22ea616b274b 100644 --- a/pfio/HistoryCollection.F90 +++ b/pfio/HistoryCollection.F90 @@ -22,6 +22,7 @@ module pFIO_HistoryCollectionMod contains procedure :: find procedure :: ModifyMetadata + procedure :: ReplaceMetadata procedure :: clear end type HistoryCollection @@ -90,6 +91,19 @@ subroutine ModifyMetadata(this,var_map,rc) _RETURN(_SUCCESS) end subroutine ModifyMetadata + subroutine ReplaceMetadata(this, fmd,rc) + class (HistoryCollection), intent(inout) :: this + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + integer :: status + character(len=*), parameter :: Iam = "HistoryCollection::ReplaceMetadata()" + + this%fmd = fmd + + _RETURN(_SUCCESS) + end subroutine ReplaceMetadata + subroutine clear(this, rc) class (HistoryCollection), intent(inout) :: this integer, optional, intent(out) :: rc diff --git a/pfio/MessageVisitor.F90 b/pfio/MessageVisitor.F90 index e2134c940693..a61123adc191 100644 --- a/pfio/MessageVisitor.F90 +++ b/pfio/MessageVisitor.F90 @@ -20,6 +20,7 @@ module pFIO_MessageVisitorMod use pFIO_DummyMessageMod use pFIO_HandShakeMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_AbstractRequestHandleMod implicit none private @@ -45,6 +46,7 @@ module pFIO_MessageVisitorMod procedure :: handle_CollectiveStageData procedure :: handle_Terminate procedure :: handle_ModifyMetadata + procedure :: handle_ReplaceMetadata procedure :: handle_HandShake generic :: handle_cmd => handle_Done @@ -61,6 +63,7 @@ module pFIO_MessageVisitorMod generic :: handle_cmd => handle_CollectiveStageData generic :: handle_cmd => handle_Terminate generic :: handle_cmd => handle_ModifyMetadata + generic :: handle_cmd => handle_ReplaceMetadata generic :: handle_cmd => handle_HandShake end type MessageVisitor @@ -116,6 +119,9 @@ recursive subroutine handle(this, message, rc) type is (ModifyMetadataMessage) call this%handle_cmd(cmd,rc=status) _VERIFY(status) + type is (ReplaceMetadataMessage) + call this%handle_cmd(cmd,rc=status) + _VERIFY(status) type is (HandShakeMessage) ! the handShake is from client to server call this%handle_cmd(cmd, rc=status) @@ -257,6 +263,15 @@ subroutine handle_ModifyMetadata(this, message, rc) _UNUSED_DUMMY(message) end subroutine handle_ModifyMetadata + subroutine handle_ReplaceMetadata(this, message, rc) + class (MessageVisitor), intent(inout) :: this + type (ReplaceMetadataMessage), intent(in) :: message + integer, optional, intent(out) :: rc + _FAIL( "Warning : dummy handle_ReplaceMetadata should not be called") + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(message) + end subroutine handle_ReplaceMetadata + subroutine handle_HandShake(this, message, rc) class (MessageVisitor), target, intent(inout) :: this type (HandShakeMessage), intent(in) :: message diff --git a/pfio/ProtocolParser.F90 b/pfio/ProtocolParser.F90 index 30ff805329be..10946bc1af62 100644 --- a/pfio/ProtocolParser.F90 +++ b/pfio/ProtocolParser.F90 @@ -18,6 +18,7 @@ module pFIO_ProtocolParserMod use pFIO_CollectivePrefetchDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_HandShakeMessageMod use pFIO_DummyMessageMod use pFIO_ForwardDataMessageMod @@ -68,6 +69,7 @@ subroutine initialize(this) type (CollectivePrefetchDataMessage) :: CollectivePrefetchData type (CollectiveStageDataMessage) :: CollectiveStageData type (ModifyMetadataMessage) :: ModifyMetadata + type (ReplaceMetadataMessage) :: ReplaceMetadata type (HandShakeMessage) :: handshake type (DummyMessage) :: dummy type (ForwardDataMessage) :: ForwardData @@ -90,6 +92,8 @@ subroutine initialize(this) call add_prototype(CollectiveStageData) ModifyMetaData = ModifyMetadataMessage(collection_id=-1) call add_prototype(ModifyMetadata) + ReplaceMetaData = ReplaceMetadataMessage(-1, FileMetadata()) + call add_prototype(ReplaceMetadata) call add_prototype(handshake) call add_prototype(dummy) call add_prototype(ForwardData) diff --git a/pfio/ReplaceMetadataMessage.F90 b/pfio/ReplaceMetadataMessage.F90 new file mode 100644 index 000000000000..4c6f4e07c86e --- /dev/null +++ b/pfio/ReplaceMetadataMessage.F90 @@ -0,0 +1,95 @@ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +module pFIO_ReplaceMetadataMessageMod + use MAPL_ExceptionHandling + use pFIO_UtilitiesMod + use pFIO_FileMetadataMod + use pFIO_AbstractMessageMod + use pFIO_StringVariableMapMod + use pFIO_StringVariableMapUtilMod + use mapl_KeywordEnforcerMod + implicit none + private + + public :: ReplaceMetadataMessage + + type, extends(AbstractMessage) :: ReplaceMetadataMessage + integer :: collection_id + type (FileMetadata) :: fmd + contains + procedure, nopass :: get_type_id + procedure :: get_length + procedure :: serialize + procedure :: deserialize + end type ReplaceMetadataMessage + + interface ReplaceMetadataMessage + module procedure new_ReplaceMetadataMessage + end interface + +contains + + function new_ReplaceMetadataMessage(collection_id, fmd, rc) result (message) + type (ReplaceMetadataMessage) :: message + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + message%collection_id = collection_id + message%fmd = fmd + + _RETURN(_SUCCESS) + end function new_ReplaceMetadataMessage + + integer function get_type_id() result(type_id) + type_id = ReplaceMetadata_ID + end function get_type_id + + integer function get_length(this) result(length) + class (ReplaceMetadataMessage), intent(in) :: this + integer, allocatable :: buffer(:) + + allocate(buffer(0)) + + call this%fmd%serialize(buffer) + + length = & + & serialize_buffer_length(this%collection_id) + & + & size(buffer) + + end function get_length + + subroutine serialize(this, buffer, rc) + class (ReplaceMetadataMessage), intent(in) :: this + integer, intent(inout) :: buffer(:) + integer, optional, intent(out) :: rc + + integer, allocatable :: fmd_buf(:) + integer :: status + + call this%fmd%serialize(fmd_buf, rc=status) + _VERIFY(status) + buffer = [ & + & serialize_intrinsic(this%collection_id), & + & fmd_buf] + _RETURN(_SUCCESS) + end subroutine serialize + + subroutine deserialize(this, buffer, rc) + class (ReplaceMetadataMessage), intent(inout) :: this + integer, intent(in) :: buffer(:) + integer, optional, intent(out) :: rc + + integer :: n, status + + n = 1 + call deserialize_intrinsic(buffer(n:), this%collection_id) + n = n + serialize_buffer_length(this%collection_id) + + call FileMetadata_deserialize(buffer(n:), this%fmd, rc=status) + _VERIFY(status) + _RETURN(_SUCCESS) + end subroutine deserialize + +end module pFIO_ReplaceMetadataMessageMod diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index caa471eecf58..58a3aa5f2b58 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -41,6 +41,7 @@ module pFIO_ServerThreadMod use pFIO_StageDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_NetCDF4_FileFormatterMod use pFIO_HistoryCollectionMod @@ -95,6 +96,7 @@ module pFIO_ServerThreadMod procedure :: handle_StageData procedure :: handle_CollectiveStageData procedure :: handle_ModifyMetadata + procedure :: handle_ReplaceMetadata procedure :: handle_HandShake procedure :: get_hist_collection @@ -593,6 +595,25 @@ subroutine handle_ModifyMetadata(this, message, rc) _RETURN(_SUCCESS) end subroutine handle_ModifyMetadata + subroutine handle_ReplaceMetadata(this, message, rc) + class (ServerThread), intent(inout) :: this + type (ReplaceMetadataMessage), intent(in) :: message + integer, optional, intent(out) :: rc + + type (HistoryCollection),pointer :: hist_collection + class(AbstractSocket),pointer :: connection + type (DummyMessage) :: handshake_msg + integer :: status + + hist_collection=>this%hist_collections%at(message%collection_id) + call hist_collection%ReplaceMetadata(message%fmd) + + connection=>this%get_connection() + call connection%send(handshake_msg,_RC) + + _RETURN(_SUCCESS) + end subroutine handle_ReplaceMetadata + subroutine handle_HandShake(this, message, rc) class (ServerThread), target, intent(inout) :: this type (HandShakeMessage), intent(in) :: message From e8e7547b64d7f2be535d84e710901213d3ca6506 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 15 Jun 2023 09:55:39 -0400 Subject: [PATCH 40/93] updates to improve benchmarking --- CHANGELOG.md | 1 + Tests/ExtDataRoot_GridComp.F90 | 39 ++++++++++++++++++++++++++++------ 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 204e7eea15d4..1d4c3dfef1a0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Added field utilities to perform basic numeric operations on fields +- Added new fill option and run mode for ExtDataDriver.x ### Changed diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index d014cb509cc1..5800b0007045 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -45,6 +45,7 @@ MODULE ExtDataUtRoot_GridCompMod end type SyntheticFieldSupportWrapper character(len=*), parameter :: runModeGenerateExports = "GenerateExports" + character(len=*), parameter :: runModeGenerateImports = "GenerateImports" character(len=*), parameter :: runModeCompareImports = "CompareImports" character(len=*), parameter :: runModeFillExportFromImport = "FillExportsFromImports" character(len=*), parameter :: runModeFillImport = "FillImport" @@ -114,6 +115,13 @@ subroutine SetServices ( GC, RC ) units = 'na', & dims = MAPL_DimsHorzOnly, & vlocation = MAPL_VLocationNone, _RC) + call MAPL_AddInternalSpec(GC,& + short_name='rand', & + long_name='random number' , & + units = 'na', & + dims = MAPL_DimsHorzOnly, & + vlocation = MAPL_VLocationNone, _RC) + call MAPL_GenericSetServices ( GC, _RC) @@ -241,6 +249,10 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call FillState(internal,export,currTime,grid,synth,_RC) + case(RunModeGenerateImports) + + call FillState(internal,import,currTime,grid,synth,_RC) + case(runModecompareImports) call FillState(internal,export,currTime,grid,synth,_RC) call CompareState(import,export,0.001,_RC) @@ -478,11 +490,12 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) real, pointer :: Exptr2(:,:) => null() integer :: itemcount character(len=ESMF_MAXSTR), allocatable :: outNameList(:) - type(ESMF_Field) :: expf,farray(6) + type(ESMF_Field) :: expf,farray(7) type(ESMF_State) :: pstate character(len=:), pointer :: fexpr - integer :: i1,in,j1,jn,ldims(3),i,j - real(kind=ESMF_KIND_R8) :: doy,time_delta + integer :: i1,in,j1,jn,ldims(3),i,j,seed_size,mypet + integer, allocatable :: seeds(:) + type(ESMF_VM) :: vm call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) call MAPL_Grid_Interior(grid,i1,in,j1,jn) @@ -491,6 +504,9 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) _VERIFY(status) call ESMF_StateGet(outState,itemNameList=outNameList,_RC) + call MAPL_GetPointer(inState,exPtr2,'time',_RC) + exPtr2=synth%tFunc%evaluate_time(Time,_RC) + call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) do j = 1,ldims(2) do i=1,ldims(1) @@ -504,16 +520,25 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) enddo enddo + call MAPL_GetPointer(inState,exPtr2,'doy',_RC) + exPtr2 = compute_doy(time,_RC) + + call MAPL_GetPointer(inState,exPtr2,'rand',_RC) + call random_seed(size=seed_size) + allocate(seeds(seed_size)) + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,localPet=mypet,_RC) + seeds = mypet + call random_seed(put=seeds) + call random_number(exPtr2) + call ESMF_StateGet(inState,'time',farray(1),_RC) - time_delta = synth%tFunc%evaluate_time(Time,_RC) - call FieldSet(farray(1), time_delta,_RC) call ESMF_StateGet(inState,'lons',farray(2),_RC) call ESMF_StateGet(inState,'lats',farray(3),_RC) call ESMF_StateGet(inState,'i_index',farray(4),_RC) call ESMF_StateGet(inState,'j_index',farray(5),_RC) call ESMF_StateGet(inState,'doy',farray(6),_RC) - doy = compute_doy(time,_RC) - call FieldSet(farray(6), doy,_RC) + call ESMF_StateGet(inState,'rand',farray(7),_RC) pstate = ESMF_StateCreate(_RC) call ESMF_StateAdd(pstate,farray,_RC) From f31fffa5177c5e44573a5d2c39b3e5e850b4ae94 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 14:36:59 -0400 Subject: [PATCH 41/93] changes for rank agnostic parser --- base/CMakeLists.txt | 2 +- base/MAPL_NewArthParser.F90 | 598 ++++------------------------- geom/FieldBinaryOperations.F90 | 7 + geom/FieldBinaryOperatorTemplate.H | 12 +- geom/FieldPointerUtilities.F90 | 31 +- geom/tests/Test_FieldArithmetic.pf | 12 +- geom/tests/Test_FieldBLAS.pf | 39 +- 7 files changed, 154 insertions(+), 547 deletions(-) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 26694bb1b3c2..abfccdcf963f 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -66,7 +66,7 @@ endif() esma_add_library( ${this} SRCS ${srcs} - DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger + DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 MAPL.geom PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL_SHARED::gftl-shared-v1 GFTL::gftl-v2 GFTL::gftl-v1 esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran TYPE ${MAPL_LIBRARY_TYPE}) diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index d714397803f5..878a22d41aca 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -53,6 +53,7 @@ MODULE MAPL_NewArthParserMod use ESMF use MAPL_BaseMod + use MAPL_Geom use MAPL_CommsMod use MAPL_ExceptionHandling use gFTL_StringVector @@ -117,6 +118,7 @@ MODULE MAPL_NewArthParserMod INTEGER :: ByteCodeSize REAL, DIMENSION(:), POINTER :: Immed => NULL() INTEGER :: ImmedSize + type(ESMF_Field), allocatable :: new_stack(:) TYPE(Ptrs_Type), DIMENSION(:), POINTER :: Stack => NULL() INTEGER :: StackSize, & StackPtr @@ -136,13 +138,13 @@ subroutine bytecode_dealloc(comp,rc) integer, optional, intent(out ) :: rc integer :: i - character(len=ESMF_MAXSTR), parameter :: Iam = "bytecode_dealloc" + integer :: status do i=1,comp%StackSize - if (associated(comp%stack(i)%Q2D)) deallocate(comp%Stack(i)%Q2D) - if (associated(comp%stack(i)%Q3D)) deallocate(comp%Stack(i)%Q3D) + call ESMF_FieldDestroy(comp%new_stack(i),noGarbage=.true.,_RC) end do deallocate(comp%Stack) + deallocate(comp%new_stack) deallocate(comp%ByteCode) deallocate(comp%Immed) _RETURN(ESMF_SUCCESS) @@ -164,37 +166,28 @@ subroutine MAPL_StateEval(state,expression,field,rc) type(tComp) :: pcode logical, allocatable :: needed(:) logical :: isConformal - character(len=ESMF_MAXSTR), parameter :: Iam="MAPL_StateEval" integer :: status - call ESMF_StateGet(state,ITEMCOUNT=varCount,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,ITEMCOUNT=varCount,_RC) allocate(fieldnames(varCount),needed(varCount)) - call ESMF_StateGet(state,itemnamelist=fieldNames,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemnamelist=fieldNames,_RC) ! confirm that each needed field is conformal - call CheckSyntax(expression,fieldNames,needed,rc=status) - _VERIFY(STATUS) + call CheckSyntax(expression,fieldNames,needed,_RC) do i=1,varCount if (needed(i)) then - call ESMF_StateGet(state,fieldNames(i),field=state_field,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,fieldNames(i),field=state_field,_RC) - isConformal = CheckIfConformal(field,state_field,rc=status) - _VERIFY(STATUS) + isConformal = FieldsAreBroadcastConformable(state_field,field,_RC) if (.not.isConformal) then _FAIL('needs informative message') end if end if end do - call parsef (pcode, expression, fieldNames, field, rc=status) - _VERIFY(STATUS) - call evalf(pcode,state,fieldNames,field,rc=status) - _VERIFY(STATUS) - call bytecode_dealloc(pcode,rc=status) - _VERIFY(STATUS) + call parsef (pcode, expression, fieldNames, field, _RC) + call evalf(pcode,state,fieldNames,field,_RC) + call bytecode_dealloc(pcode,_RC) deallocate(fieldNames,needed) @@ -213,16 +206,13 @@ SUBROUTINE parsef (Comp, FuncStr, Var, field, rc) INTEGER, OPTIONAL , INTENT(out ) :: rc CHARACTER(len=LEN(FuncStr)) :: Func - character(len=ESMF_MAXSTR), parameter :: Iam="parsef" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- - CALL CheckSyntax (FuncStr,Var,rc=status) - _VERIFY(STATUS) + CALL CheckSyntax (FuncStr,Var,_RC) Func = FuncStr ! Local copy of function string CALL Replace ('**','^ ',Func) ! Exponent into 1-Char. format CALL RemoveSpaces (Func) ! Condense function string - CALL Compile (comp,Func,Var,field,rc=status) ! Compile into bytecode - _VERIFY(STATUS) + CALL Compile (comp,Func,Var,field,_RC) ! Compile into bytecode _RETURN(ESMF_SUCCESS) END SUBROUTINE parsef ! @@ -241,7 +231,6 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) SP ! Stack pointer INTEGER :: CurrByte,ValNumber TYPE(ESMF_Field) :: state_field - character(len=ESMF_MAXSTR), parameter :: Iam="evalf" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- DP = 1 @@ -250,500 +239,98 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) CurrByte = Comp%ByteCode(IP) if (CurrByte == cImmed) then SP=SP+1 - call CopyScalarToField(Comp%Stack(SP),Comp%Immed(DP),rc=status) - _VERIFY(STATUS) + call FieldSet(comp%new_stack(sp),comp%immed(dp),_RC) DP=DP+1 end if if (CurrByte == cNeg) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call FieldNegate(comp%new_stack(sp),_RC) end if if (CurrByte >= cAdd .and. CurrByte <= cPow) then - call ArthFieldToField(Comp%Stack(SP),Comp%Stack(SP-1),CurrByte,rc=status) - _VERIFY(STATUS) + call field_binary(Comp%new_stack(SP),Comp%new_stack(SP-1),CurrByte,_RC) SP=SP-1 end if if (CurrByte >= cAbs .and. CurrByte <= cHeav) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call field_unary(comp%new_stack(sp),currByte,_RC) end if if (CurrByte > cHeav) then SP=SP+1 ValNumber = CurrByte-VarBegin+1 - call ESMF_StateGet(state,FieldNames(ValNumber),state_field,rc=status) - _VERIFY(STATUS) - call CopyFieldToPtr(state_field,Comp%Stack(SP),rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,FieldNames(ValNumber),state_field,_RC) + call FieldCopyBroadcast(state_field,comp%new_stack(sp),_RC) end if END DO - call CopyPtrToField(Comp%Stack(1),ResField,rc=status) - _VERIFY(STATUS) + call FieldCopyBroadcast(comp%new_stack(1),ResField,_RC) _RETURN(ESMF_SUCCESS) END SUBROUTINE evalf - FUNCTION CheckIfConformal(field_1,field_2,rc) result(res) - TYPE(ESMF_Field), intent(inout) :: field_1 - TYPE(ESMF_Field), intent(inout) :: field_2 - integer, optional, intent(out ) :: rc - - logical :: res - - character(len=ESMF_MAXSTR), parameter :: Iam ="CheckIfConformal" - integer :: status - type(ESMF_Array) :: array_1,array_2 - type (ESMF_LocalArray), target :: larrayList(1) - type(ESMF_LocalArray), pointer :: larray_1,larray_2 - integer :: rank_1, rank_2 - integer :: lbnds_1(ESMF_MAXDIM), ubnds_1(ESMF_MAXDIM) - integer :: lbnds_2(ESMF_MAXDIM), ubnds_2(ESMF_MAXDIM) - integer :: i - - call ESMF_FieldGet(field_1,array=array_1,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_1, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_1 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_1,rank=rank_1,totalLBound=lbnds_1,totalUBound=ubnds_1,rc=status) - _VERIFY(STATUS) - - call ESMF_FieldGet(field_2,array=array_2,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_2, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_2 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_2,rank=rank_2,totalLBound=lbnds_2,totalUBound=ubnds_2,rc=status) - _VERIFY(STATUS) - - if (rank_1 == 2 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 3) then - do i=1,3 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 2 .and. rank_2 == 3) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - - _RETURN(ESMF_SUCCESS) - - END FUNCTION CheckIfConformal + subroutine field_binary(field1,field2,arthcode,rc) + type(ESMF_Field), intent(inout) :: field1 + type(ESMF_Field), intent(inout) :: field2 + integer, intent(in) :: arthcode + integer, optional, intent(out) :: rc - SUBROUTINE CopyFieldtoPtr(field,ptrs,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" integer :: status - integer :: i - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - ptrs%Q3D=var3d - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - ptrs%Q2D=var2d - else if (rank == 2 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - do i=ptrs%lb(3),ptrs%ub(3) - ptrs%Q3D(:,:,i)=var2d - end do - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyFieldToPtr - - SUBROUTINE CopyPtrtoField(ptrs,field,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" - integer :: status - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - var3d=ptrs%Q3D - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - var2d=ptrs%Q2D - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyPtrToField - - - SUBROUTINE ArthFieldToField(ptrs_1,ptrs_2,arthcode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(Ptrs_Type), intent(inout) :: ptrs_1 - TYPE(Ptrs_Type), intent(inout) :: ptrs_2 - integer, intent(in ) :: arthcode - integer, optional, intent(out ) :: rc - Character(len=ESMF_MAXSTR), parameter :: Iam="ArthFieldToField" - - if (ptrs_1%rank == 3 .and. ptrs_2%rank ==3) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D + ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D - ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D * ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D / ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D ** ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs_1%rank == 2 .and. ptrs_2%rank ==2) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D + ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D - ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D * ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D / ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D ** ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - end select -! maybe put in 2d + 3d, not needed for now - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE ArthFieldToField - - SUBROUTINE UnaryFuncField(ptrs,funcCode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(ptrs_type), intent(inout) :: ptrs + select case(arthcode) + case(cAdd) + call FieldAdd(field2,field2,field1,_RC) + case(cSub) + call FieldSubtract(field2,field2,field1,_RC) + case(cMul) + call FieldMultiply(field2,field2,field1,_RC) + case(cDiv) + call FieldDivide(field2,field2,field1,_RC) + case(cPow) + call FieldPower(field2,field2,field1,_RC) + end select + _RETURN(_SUCCESS) + end subroutine field_binary + + subroutine field_unary(field,funcCode,rc) + type(ESMF_Field), intent(inout) :: field integer, intent(in ) :: funcCode integer, optional, intent(out ) :: rc - character(len=ESMF_MAXSTR), parameter :: Iam="UnaryFuncField" - - if (ptrs%rank == 3) then - select case(funcCode) - case(cNeg) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = -ptrs%Q3D - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = abs(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = exp(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log10(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sqrt(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sinh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cosh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tanh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = asin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = acos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = atan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = Heav3D(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs%rank == 2) then - select case(funcCode) - case(cNeg) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = -ptrs%Q2D - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = abs(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = exp(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log10(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sqrt(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sinh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cosh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tanh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = asin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = acos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = atan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = Heav2D(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - end select - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE UnaryFuncField - - SUBROUTINE CopyScalarToField(ptrs,rn,rc) - ! copy a scalar to ESMF field - TYPE(Ptrs_Type), intent(inout) :: ptrs - real, intent(in ) :: rn - integer, optional, intent(out ) :: rc - - character(len=ESMF_MAXSTR), parameter :: Iam="CopyScalarToField" + integer :: status - if (ptrs%rank == 2) then - ptrs%Q2D=rn - else if (ptrs%rank == 3) then - ptrs%Q3D=rn - end if - _RETURN(ESMF_SUCCESS) + select case(funcCode) + case(cNeg) + call FieldNegate(field,_RC) + case(cAbs) + call FieldAbs(field,field,_RC) + case(cExp) + call FieldExp(field,field,_RC) + case(cLog10) + call FieldLog10(field,field,_RC) + case(cLog) + call FieldLog(field,field,_RC) + case(cSqrt) + call FieldSqrt(field,field,_RC) + case(cSinh) + call FieldSinh(field,field,_RC) + case(cCosh) + call FieldCosh(field,field,_RC) + case(cTanh) + call FieldTanh(field,field,_RC) + case(cSin) + call FieldSin(field,field,_RC) + case(cCos) + call FieldCos(field,field,_RC) + case(cTan) + call FieldTan(field,field,_RC) + case(cAsin) + call FieldAsin(field,field,_RC) + case(cAcos) + call FieldAcos(field,field,_RC) + case(cAtan) + call FieldAtan(field,field,_RC) + case(cHeav) + _FAIL("heaviside needs implementation") + end select + + _RETURN(_SUCCESS) + end subroutine field_unary - END SUBROUTINE CopyScalarToField - ! function parser_variables_in_expression (FuncStr,rc) result(variables_in_expression) !----- -------- --------- --------- --------- --------- --------- --------- ------- ! Check syntax of function string, returns 0 if syntax is ok @@ -761,7 +348,6 @@ function parser_variables_in_expression (FuncStr,rc) result(variables_in_express LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -882,7 +468,6 @@ SUBROUTINE CheckSyntax (FuncStr,Var,needed,ExtVar,rc) LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -1194,7 +779,6 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) INTEGER :: ResRank INTEGER :: lb(ESMF_MAXDIM) INTEGER :: ub(ESMF_MAXDIM) - character(len=ESMF_MAXSTR), parameter :: Iam = "Compile" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- IF (ASSOCIATED(Comp%ByteCode)) DEALLOCATE ( Comp%ByteCode, & @@ -1208,24 +792,12 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) ALLOCATE ( Comp%ByteCode(Comp%ByteCodeSize), & Comp%Immed(Comp%ImmedSize), & Comp%Stack(Comp%StackSize), & + Comp%new_stack(comp%stackSize), & STAT = istat ) - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,localarrayList=larrayList,rc=status) - _VERIFY(STATUS) - lArray => lArrayList(1) - call ESMF_LocalArrayGet(larray,rank=ResRank,totallbound=lb,totalubound=ub,rc=status) - _VERIFY(STATUS) DO i=1,Comp%StackSize - Comp%Stack(i)%rank = ResRank - Comp%Stack(i)%lb = lb - Comp%Stack(i)%ub = ub - IF (ResRank == 2) then - allocate(Comp%Stack(i)%Q2D(lb(1):ub(1),lb(2):ub(2)) ) - ELSE IF (ResRank == 3) then - allocate(Comp%Stack(i)%Q3D(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) ) - END IF + call FieldClone(field,comp%new_stack(i),_RC) + call ESMF_AttributeSet(field,name="missing_value",value=MAPL_UNDEF,_RC) END DO Comp%ByteCodeSize = 0 diff --git a/geom/FieldBinaryOperations.F90 b/geom/FieldBinaryOperations.F90 index c675f0e5a908..3b4bbff8f706 100644 --- a/geom/FieldBinaryOperations.F90 +++ b/geom/FieldBinaryOperations.F90 @@ -12,6 +12,7 @@ module MAPL_FieldBinaryOperations public fieldSubtract public fieldDivide public fieldMultiply + public fieldPower contains @@ -39,4 +40,10 @@ module MAPL_FieldBinaryOperations #undef _OP #undef _FUNC +#define _OP ** +#define _FUNC Power +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + end module MAPL_FieldBinaryOperations diff --git a/geom/FieldBinaryOperatorTemplate.H b/geom/FieldBinaryOperatorTemplate.H index 4bae5cc5fb03..765f28b7263e 100644 --- a/geom/FieldBinaryOperatorTemplate.H +++ b/geom/FieldBinaryOperatorTemplate.H @@ -39,12 +39,12 @@ if (has_undef) then call GetFieldsUndef(fields,undef_r4,_RC) where( (ptr1_r4 /= undef_r4(1)) .and. (ptr2_r4 /= undef_r4(2)) ) - ptr1_r4 = ptr1_r4 _OP ptr2_r4 + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 elsewhere - ptr1_r4 = undef_r4(3) + ptr_out_r4 = undef_r4(3) end where else - ptr1_r4 = ptr1_r4 _OP ptr2_r4 + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 end if else if (tk_A == ESMF_TypeKind_R8) then call assign_fptr(field_a,ptr1_r8,_RC) @@ -53,12 +53,12 @@ if (has_undef) then call GetFieldsUndef(fields,undef_r8,_RC) where( (ptr1_r8 /= undef_r8(1)) .and. (ptr2_r8 /= undef_r8(2)) ) - ptr1_r8 = ptr1_r8 _OP ptr2_r8 + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 else where - ptr1_r8 = undef_r8(3) + ptr_out_r8 = undef_r8(3) endwhere else - ptr1_r8 = ptr1_r8 _OP ptr2_r8 + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 end if else _FAIL("unsupported type") diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 4e40762e6172..41ca1bcbfed0 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -363,25 +363,29 @@ subroutine clone(x, y, rc) integer, optional, intent(out) :: rc character(len=*), parameter :: CLONE_TAG = '_clone' - type(ESMF_ArraySpec) :: arrayspec + !type(ESMF_ArraySpec) :: arrayspec type(ESMF_Grid) :: grid type(ESMF_StaggerLoc) :: staggerloc integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungriddedLBound(:) integer, allocatable :: ungriddedUBound(:) - integer, allocatable :: totalLWidth(:,:) - integer, allocatable :: totalUWidth(:,:) + type(ESMF_TypeKind_Flag) :: tk character(len=:), allocatable :: name integer :: status - - call ESMF_FieldGet(x, arrayspec=arrayspec, grid=grid, & + integer :: field_rank, grid_rank,ungrid_size + + call ESMF_FieldGet(x,grid=grid,rank=field_rank,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank,_RC) + ungrid_size = field_rank-grid_rank + allocate(gridToFieldMap(grid_rank)) + allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) + call ESMF_FieldGet(x, typekind=tk, & staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & - totalLWidth=totalLWidth, totalUWidth=totalUWidth, _RC) + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) name = name // CLONE_TAG - y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & + y = ESMF_FieldCreate(grid, typekind=tk, staggerloc=staggerloc, & gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & ungriddedUBound=ungriddedUBound, name=name, _RC) @@ -439,12 +443,19 @@ logical function are_broadcast_conformable(x, y, rc) result(conformable) integer :: rank_x, rank_y integer, dimension(:), allocatable :: count_x, count_y integer :: status + logical :: normal_conformable + conformable = .false. ! this should really used the geom and ungridded dims ! for now we will do this until we have a geom agnostic stuff worked out... ! the ideal algorithm would be if geom == geom and input does not have ungridded ! and thing we are copying to does, then we are "conformable" - conformable = .false. + normal_conformable = FIeldsAreConformable(x,y,_RC) + + if (normal_conformable) then + conformable = .true. + _RETURN(_SUCCESS) + end if call ESMF_FieldGet(x, rank=rank_x, _RC) call ESMF_FieldGet(y, rank=rank_y, _RC) @@ -540,7 +551,7 @@ subroutine copy_broadcast(x, y, rc) _RETURN(_SUCCESS) end if broadcast = FieldsAreBroadcastConformable(x,y) - _ASSERT(broadcast, 'FieldCopy() - fields not be broadcast.') + _ASSERT(broadcast, 'FieldCopy() - field can not be broadcast.') call MAPL_FieldGetLocalElementCount(x,x_shape,_RC) call MAPL_FieldGetLocalElementCount(y,y_shape,_RC) diff --git a/geom/tests/Test_FieldArithmetic.pf b/geom/tests/Test_FieldArithmetic.pf index 84d63e1c6f61..a0325a702a98 100644 --- a/geom/tests/Test_FieldArithmetic.pf +++ b/geom/tests/Test_FieldArithmetic.pf @@ -62,8 +62,8 @@ contains y_ptr = 3.0 result_array = x_ptr result_array = 5.0 - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4 @Test @@ -83,8 +83,8 @@ contains y_ptr = reshape(source=[undef,3.0,3.0,undef],shape=[2,2]) result_array = x_ptr result_array = reshape(source=[undef,5.0,5.0,undef],shape=[2,2]) - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4_missing @Test @@ -104,8 +104,8 @@ contains y_ptr = 3.d0 result_array = x_ptr result_array = 5.d0 - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR8 @Test diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 7cb31c63a202..df6fcb90f59d 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -342,23 +342,40 @@ contains !@Test !wdb fixme not done yet - subroutine test_FieldClone() + subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc -! type(ESMF_ArraySpec) :: arrayspec -! type(ESMF_Grid) :: grid -! type(ESMF_StaggerLoc) :: staggerloc -! integer, allocatable :: gridToFieldMap(:) -! integer, allocatable :: ungriddedLBound(:) -! integer, allocatable :: ungriddedUBound(:) -! integer, allocatable :: totalLWidth(:,:) -! integer, allocatable :: totalUWidth(:,:) + type(ESMF_TypeKind_Flag) :: tk_x,tk_y + type(ESMF_Grid) :: grid + integer, allocatable :: ungriddedLBound_x(:),ungriddedLBound_y(:) + integer, allocatable :: ungriddedUBound_x(:),ungriddedUBound_y(:) + integer :: grid_rank_x, grid_rank_y + integer :: field_rank_x, field_rank_y + integer :: ungrid_x,ungrid_y + + x = XR4_3D + + call ESMF_FieldGet(x,rank=field_rank_x,grid=grid,typekind=tk_x,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_x) + ungrid_x = field_rank_x - grid_rank_x + allocate(ungriddedLBound_x(ungrid_x),ungriddedUBound_x(ungrid_x)) + call ESMF_FieldGet(x,ungriddedLBound=UngriddedLBound_x,ungriddedUBound=UngriddedUBound_x,_RC) - x = XR4 call FieldClone(x, y, _RC) - end subroutine test_FieldClone + call ESMF_FieldGet(y,rank=field_rank_y,grid=grid,typekind=tk_y,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_y) + ungrid_y = field_rank_y - grid_rank_y + allocate(ungriddedLBound_y(ungrid_y),ungriddedUBound_y(ungrid_y)) + call ESMF_FieldGet(y,ungriddedLBound=UngriddedLBound_y,ungriddedUBound=UngriddedUBound_y,_RC) + @assertEqual(field_rank_x,field_rank_y) + @assertEqual(ungrid_x,ungrid_y) + @assertTrue(tk_x==tk_y,"kinds not equal") + @assertEqual(ungriddedLBound_x,ungriddedLBound_y) + @assertEqual(ungriddedUBound_x,ungriddedUBound_y) + + end subroutine test_FieldClone3D @Test subroutine test_almost_equal_scalar() From 9294138e35f9ad30c32fdc31bec842b3fe85cb9f Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 14:37:50 -0400 Subject: [PATCH 42/93] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 204e7eea15d4..4c8a40b6d2d6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Added field utilities to perform basic numeric operations on fields +- Update arithemetic parser to work with any rank and type of ESMF fields ### Changed From df5af75868b267ac8a1366cca50bf0935d67c587 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 15:17:21 -0400 Subject: [PATCH 43/93] get clone test working --- geom/tests/Test_FieldBLAS.pf | 7 +++++-- geom/tests/geom_setup.F90 | 39 +++++++++++++++++++++++++++--------- 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index df6fcb90f59d..a117273fa507 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -36,6 +36,10 @@ contains indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + XR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) + YR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) end subroutine set_up_data @@ -340,8 +344,7 @@ contains end subroutine test_FieldConvertPrec_R4R8 - !@Test - !wdb fixme not done yet + @Test subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc diff --git a/geom/tests/geom_setup.F90 b/geom/tests/geom_setup.F90 index 957925beca16..e43f6b43c7ad 100644 --- a/geom/tests/geom_setup.F90 +++ b/geom/tests/geom_setup.F90 @@ -9,8 +9,8 @@ module geom_setup implicit none interface mk_field - module procedure mk_field_r4 - module procedure mk_field_r8 + module procedure mk_field_r4_2d + module procedure mk_field_r8_2d end interface mk_field interface initialize_array @@ -60,9 +60,27 @@ function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result _RETURN(_SUCCESS) end function mk_grid + + function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: name + integer, optional, intent(in) :: ungriddedLBound(:) + integer, optional, intent(in) :: ungriddedUBound(:) + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + + _RETURN(_SUCCESS) + end function mk_field_r4_ungrid - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R4) - function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex @@ -81,10 +99,9 @@ function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) ptr => farray _RETURN(_SUCCESS) - end function mk_field_r4 + end function mk_field_r4_2d - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R8) - function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex @@ -103,15 +120,17 @@ function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) ptr => farray _RETURN(_SUCCESS) - end function mk_field_r8 + end function mk_field_r8_2d - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) type(ESMF_TypeKind_Flag), intent(in) :: tk integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex integer, dimension(:), intent(in) :: maxIndex type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name + integer, optional, intent(in) :: ungriddedLBound(:) + integer, optional, intent(in) :: ungriddedUBound(:) integer, optional, intent(out) :: rc character(len=*), parameter :: GRID_SUFFIX = '_grid' character(len=*), parameter :: FIELD_SUFFIX = '_field' @@ -121,7 +140,7 @@ function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) integer :: status grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) - field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, _RC) + field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) _RETURN(_SUCCESS) end function mk_field_common From 3f5cb5fc2de9c6694ed49836fadb19e793142b54 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 15:49:22 -0400 Subject: [PATCH 44/93] remove unused code in arth parser after refactoring --- base/MAPL_NewArthParser.F90 | 41 +++++++++++-------------------------- 1 file changed, 12 insertions(+), 29 deletions(-) diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index 878a22d41aca..a96787cf15df 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -1,5 +1,4 @@ #include "MAPL_Generic.h" -! ! Part of this code is based on a fortran parser by Roland Schmehl: ! !------- -------- --------- --------- --------- --------- --------- --------- ------- @@ -118,19 +117,11 @@ MODULE MAPL_NewArthParserMod INTEGER :: ByteCodeSize REAL, DIMENSION(:), POINTER :: Immed => NULL() INTEGER :: ImmedSize - type(ESMF_Field), allocatable :: new_stack(:) - TYPE(Ptrs_Type), DIMENSION(:), POINTER :: Stack => NULL() + type(ESMF_Field), allocatable :: stack(:) INTEGER :: StackSize, & StackPtr END TYPE tComp - type Ptrs_Type - integer:: rank - integer, dimension(ESMF_MAXDIM):: lb,ub - real, pointer:: Q2D(:,: ) => null() - real, pointer:: Q3D(:,:,:) => null() - end type Ptrs_Type - CONTAINS subroutine bytecode_dealloc(comp,rc) @@ -141,10 +132,9 @@ subroutine bytecode_dealloc(comp,rc) integer :: status do i=1,comp%StackSize - call ESMF_FieldDestroy(comp%new_stack(i),noGarbage=.true.,_RC) + call ESMF_FieldDestroy(comp%stack(i),noGarbage=.true.,_RC) end do - deallocate(comp%Stack) - deallocate(comp%new_stack) + deallocate(comp%stack) deallocate(comp%ByteCode) deallocate(comp%Immed) _RETURN(ESMF_SUCCESS) @@ -239,27 +229,27 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) CurrByte = Comp%ByteCode(IP) if (CurrByte == cImmed) then SP=SP+1 - call FieldSet(comp%new_stack(sp),comp%immed(dp),_RC) + call FieldSet(comp%stack(sp),comp%immed(dp),_RC) DP=DP+1 end if if (CurrByte == cNeg) then - call FieldNegate(comp%new_stack(sp),_RC) + call FieldNegate(comp%stack(sp),_RC) end if if (CurrByte >= cAdd .and. CurrByte <= cPow) then - call field_binary(Comp%new_stack(SP),Comp%new_stack(SP-1),CurrByte,_RC) + call field_binary(Comp%stack(SP),Comp%stack(SP-1),CurrByte,_RC) SP=SP-1 end if if (CurrByte >= cAbs .and. CurrByte <= cHeav) then - call field_unary(comp%new_stack(sp),currByte,_RC) + call field_unary(comp%stack(sp),currByte,_RC) end if if (CurrByte > cHeav) then SP=SP+1 ValNumber = CurrByte-VarBegin+1 call ESMF_StateGet(state,FieldNames(ValNumber),state_field,_RC) - call FieldCopyBroadcast(state_field,comp%new_stack(sp),_RC) + call FieldCopyBroadcast(state_field,comp%stack(sp),_RC) end if END DO - call FieldCopyBroadcast(comp%new_stack(1),ResField,_RC) + call FieldCopyBroadcast(comp%stack(1),ResField,_RC) _RETURN(ESMF_SUCCESS) END SUBROUTINE evalf @@ -773,17 +763,11 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) TYPE(ESMF_Field) , INTENT(inout) :: field ! resultant field, use to get its rank, etc . . . INTEGER , INTENT(out ) :: rc INTEGER :: istat, i - TYPE(ESMF_Array) :: Array - type (ESMF_LocalArray), target :: larrayList(1) - TYPE(ESMF_LocalArray) ,pointer :: lArray - INTEGER :: ResRank - INTEGER :: lb(ESMF_MAXDIM) - INTEGER :: ub(ESMF_MAXDIM) integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- IF (ASSOCIATED(Comp%ByteCode)) DEALLOCATE ( Comp%ByteCode, & Comp%Immed, & - Comp%Stack ) + Comp%stack ) Comp%ByteCodeSize = 0 Comp%ImmedSize = 0 Comp%StackSize = 0 @@ -791,12 +775,11 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) CALL CompileSubstr (Comp,F,1,LEN_TRIM(F),Var) ! Compile string to determine size ALLOCATE ( Comp%ByteCode(Comp%ByteCodeSize), & Comp%Immed(Comp%ImmedSize), & - Comp%Stack(Comp%StackSize), & - Comp%new_stack(comp%stackSize), & + Comp%stack(comp%stackSize), & STAT = istat ) DO i=1,Comp%StackSize - call FieldClone(field,comp%new_stack(i),_RC) + call FieldClone(field,comp%stack(i),_RC) call ESMF_AttributeSet(field,name="missing_value",value=MAPL_UNDEF,_RC) END DO From cb32cbae1b0a205343d3a42e003d0083d4e34a32 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 16:39:47 -0400 Subject: [PATCH 45/93] fix gnu bug --- geom/FieldPointerUtilities.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 41ca1bcbfed0..5cc056cc5720 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -370,7 +370,7 @@ subroutine clone(x, y, rc) integer, allocatable :: ungriddedLBound(:) integer, allocatable :: ungriddedUBound(:) type(ESMF_TypeKind_Flag) :: tk - character(len=:), allocatable :: name + character(len=ESMF_MAXSTR) :: name integer :: status integer :: field_rank, grid_rank,ungrid_size @@ -379,11 +379,11 @@ subroutine clone(x, y, rc) ungrid_size = field_rank-grid_rank allocate(gridToFieldMap(grid_rank)) allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) - call ESMF_FieldGet(x, typekind=tk, & + call ESMF_FieldGet(x, typekind=tk, name = name, & staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) - name = name // CLONE_TAG + name = trim(name) // CLONE_TAG y = ESMF_FieldCreate(grid, typekind=tk, staggerloc=staggerloc, & gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & From 9f340b22eb47cbdbdccfea1c3f42c4669319a7fc Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 22 Jun 2023 08:26:09 -0400 Subject: [PATCH 46/93] Update CI BCs to v11.1.0 --- .circleci/config.yml | 2 +- CHANGELOG.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 676783f94c67..fe0d9950a295 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -17,7 +17,7 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 baselibs_version: &baselibs_version v7.13.0 -bcs_version: &bcs_version v11.00.0 +bcs_version: &bcs_version v11.1.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: diff --git a/CHANGELOG.md b/CHANGELOG.md index 7b272c2398a2..abb5e4977931 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -33,6 +33,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - ESMA_cmake v3.28.0 → v3.29.0 - Clean up for TOSS4 changes at NAS - Make the GEOSadas CI build separate as it often fails due to race conditions in GSI +- Update CI to use BCs v11.1.0 ### Fixed From f492effb631ca01842ec0a9978c0fced10365736 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 26 Jun 2023 09:19:02 -0400 Subject: [PATCH 47/93] Fixes #2081. Remove unneeded and confusing default in History --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 17 ++++++++--------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c6d7feb4ebd1..75f7698f9a12 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,6 +39,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed - Created cubed-sphere grid factory with files split by face +- Removed unneeded and confusing default in History Grid Comp (see #2081) ### Removed diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index cd31929bc6d8..78dad62acc59 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -194,10 +194,10 @@ end subroutine SetServices ! Diagnostics have the following attributes: ! !1. Diagnostics may be `instantaneous` or `time-averaged` -!2. Diagnostics have a `frequency` and an associated `ref_date` and `ref_time` -! from which the frequency is based. An `end_date` and `end_time` may also be +!2. Diagnostics have a `frequency` and an associated `ref_date` and `ref_time` +! from which the frequency is based. An `end_date` and `end_time` may also be ! used to turn off diagnostics after a given date and time. -!3. Time-Averaged Diagnostics have an associated accumulation interval, +!3. Time-Averaged Diagnostics have an associated accumulation interval, ! `acc_interval`, which may be <= to the diagnostic `frequency` !4. Diagnostics are `time-stamped` with the center of the time-averaged period. !5. The default `acc_interval` is the diagnostic `frequency` @@ -209,7 +209,7 @@ end subroutine SetServices ! History Lists contain the following attributes: ! !- **filename**: Character string defining the filename of a particular diagnostic output stream. -!- **template**: Character string defining the time stamping template following GrADS convensions. +!- **template**: Character string defining the time stamping template following GrADS convensions. ! The default value depends on the duration of the file. !- **format**: Character string defining file format ("flat" or "CFIO"). Default = "flat". !- **mode**: Character string equal to "instantaneous" or "time-averaged". Default = "instantaneous". @@ -863,8 +863,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if end if if (has_regrid_keyword) then - call ESMF_ConfigGetAttribute ( cfg, regrid_method, default="REGRID_METHOD_BILINEAR", & - label=trim(string) // 'regrid_method:' ,_RC ) + call ESMF_ConfigGetAttribute ( cfg, regrid_method, label=trim(string) // 'regrid_method:' ,_RC ) list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if @@ -3611,9 +3610,9 @@ subroutine Run ( gc, import, export, clock, rc ) end subroutine Run !====================================================== -!> +!> ! Finanlize the `MAPL_HistoryGridComp` component. -! +! subroutine Finalize ( gc, import, export, clock, rc ) type(ESMF_GridComp), intent(inout) :: gc !! composite gridded component @@ -5105,7 +5104,7 @@ subroutine CopyStateItems(src, dst, rc) call ESMF_StateGet(src, itemNames(n), bundle(1), _RC) call ESMF_StateAdd(dst, bundle, _RC) end if - end do + end do deallocate(itemTypes) deallocate(itemNames) From 2dcf3d3554c73a229a7645e77460d8a72864acbb Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 30 Jun 2023 10:24:36 -0400 Subject: [PATCH 48/93] updates due to hconfig api change --- gridcomps/ExtData2G/ExtDataConfig.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index 1b2710341b1a..3543d014ebc9 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -50,7 +50,7 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ type(ESMF_HConfig) :: input_config type(ESMF_HConfig) :: temp_configs - type(ESMF_HConfig) :: hconfigIter,hconfigIterBegin,hconfigIterEnd + type(ESMF_HConfigIter) :: hconfigIter,hconfigIterBegin,hconfigIterEnd character(len=:), allocatable :: hconfig_key type(ESMF_HConfig) :: single_sample,single_collection,single_export,rule_map,hconfig_val From bfa965cbf7e3e132c50ed6c547e40a4a889ab6c0 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 08:30:02 -0600 Subject: [PATCH 49/93] Baby Step 1 From c18c9010d176587f8c4ef42d3060c33e5c24af38 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 09:48:27 -0600 Subject: [PATCH 50/93] WIP.1 --- gridcomps/History/MAPL_HistoryCollection.F90 | 6 +- gridcomps/History/MAPL_HistoryGridComp.F90 | 13 ++- .../History/MAPL_HistoryTrajectoryMod.F90 | 110 +++++++++++++++--- 3 files changed, 111 insertions(+), 18 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 13e4daeb1e8a..b40aa657aa92 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -101,7 +101,7 @@ module MAPL_HistoryCollectionMod character(len=ESMF_MAXSTR) :: output_grid_label type(GriddedIOItemVector) :: items character(len=ESMF_MAXSTR) :: currentFile - character(len=ESMF_MAXPATHLEN) :: trackFile + character(len=ESMF_MAXPATHLEN) :: obsFile character(len=ESMF_MAXPATHLEN) :: stationIdFile logical :: splitField logical :: regex @@ -112,6 +112,10 @@ module MAPL_HistoryCollectionMod character(len=ESMF_MAXSTR) :: sampler_spec = "" character(len=ESMF_MAXSTR) :: positive type(HistoryCollectionGlobalAttributes) :: global_atts + character(len=ESMF_MAXSTR) :: nc_index + character(len=ESMF_MAXSTR) :: nc_time + character(len=ESMF_MAXSTR) :: nc_latitude + character(len=ESMF_MAXSTR) :: nc_longitude contains procedure :: AddGrid end type HistoryCollection diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 78dad62acc59..7c4e785c7efa 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -873,9 +873,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label=trim(string) // 'station_id_file:', _RC) ! Get an optional file containing a 1-D track for the output - call ESMF_ConfigGetAttribute(cfg, value=list(n)%trackFile, default="", & + call ESMF_ConfigGetAttribute(cfg, value=list(n)%obsFile, default="", & label=trim(string) // 'track_file:', _RC) - if (trim(list(n)%trackfile) /= '') list(n)%timeseries_output = .true. + if (trim(list(n)%obsFile) /= '') list(n)%timeseries_output = .true. call ESMF_ConfigGetAttribute(cfg, value=list(n)%recycle_track, default=.false., & label=trim(string) // 'recycle_track:', _RC) @@ -2338,6 +2338,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) do n=1,nlist if (list(n)%disabled) cycle + string = trim( list(n)%collection ) // '.' + cfg = ESMF_ConfigCreate(_RC) + call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', _RC) if (list(n)%format == 'CFIOasync') then list(n)%format = 'CFIO' if (mapl_am_i_root()) write(*,*)'Chose CFIOasync setting to CFIO, update your History.rc file' @@ -2367,8 +2370,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then - list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),_RC) +! list(n)%trajectory = HistoryTrajectory(trim(list(n)%obsFile),_RC) +! call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) + list(n)%trajectory = HistoryTrajectory(cfg,_RC) call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) + elseif (list(n)%sampler_spec == 'station') then list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile),_RC) call list(n)%station_sampler%add_metadata_route_handle(list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,_RC) @@ -2384,6 +2390,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) end if end if + call ESMF_ConfigDestroy(cfg, _RC) end do ! Echo History List Data Structure diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index dd63f711a17a..0e25fa4ebda0 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -43,6 +43,15 @@ module HistoryTrajectoryMod character(LEN=ESMF_MAXPATHLEN) :: file_name type(TimeData) :: time_info logical :: recycle_track + character(len=ESMF_MAXSTR) :: obsFile + character(len=ESMF_MAXSTR) :: nc_index + character(len=ESMF_MAXSTR) :: nc_time + character(len=ESMF_MAXSTR) :: nc_latitude + character(len=ESMF_MAXSTR) :: nc_longitude + character(len=ESMF_MAXSTR) :: var_name_time + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: tunit contains procedure :: initialize procedure :: create_variable @@ -55,15 +64,16 @@ module HistoryTrajectoryMod procedure :: get_file_start_time procedure :: get procedure :: reset_times_to_current_day + procedure :: sort_arrays_by_time end type interface HistoryTrajectory - module procedure HistoryTrajectory_from_file + module procedure HistoryTrajectory_from_config end interface HistoryTrajectory contains - function HistoryTrajectory_from_file(filename,unusable,rc) result(trajectory) + function HistoryTrajectory_from_config(filename,unusable,rc) result(trajectory) type(HistoryTrajectory) :: trajectory character(len=*), intent(in) :: filename class (KeywordEnforcer), optional, intent(in) :: unusable @@ -71,31 +81,76 @@ function HistoryTrajectory_from_file(filename,unusable,rc) result(trajectory) integer :: status type(NetCDF4_FileFormatter) :: formatter - type(FileMetadataUtils) :: metadata + type(FileMetadataUtils) :: metadata_utils type(FileMetadata) :: basic_metadata integer :: num_times _UNUSED_DUMMY(unusable) + !__ nc_info + ! + call ESMF_ConfigGetAttribute(config, value=trajectory%obsFile, default="", & + label=trim(string) // 'obs_file:', _RC) + call ESMF_ConfigGetAttribute(config, value=trajectory%nc_index, default="", & + label=trim(string) // 'nc_Index:', _RC) + call ESMF_ConfigGetAttribute(config, value=trajectory%nc_time, default="", & + label=trim(string) // 'nc_Time:', _RC) + call ESMF_ConfigGetAttribute(config, value=trajectory%nc_longitude, default="", & + label=trim(string) // 'nc_Longitude:', _RC) + call ESMF_ConfigGetAttribute(config, value=trajectory%nc_latitude, default="", & + label=trim(string) // 'nc_Latitude:', _RC) + call formatter%open(trim(filename),pFIO_READ,_RC) - basic_metadata = formatter%read(_RC) - call metadata%create(basic_metadata,trim(filename)) - num_times = metadata%get_dimension("time",_RC) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) - if (metadata%is_var_present("longitude")) then - call formatter%get_var("longitude",trajectory%lons,_RC) - end if - if (metadata%is_var_present("latitude")) then - call formatter%get_var("latitude",trajectory%lats,_RC) - end if + if (trajectory%nc_index == '') then + basic_metadata = formatter%read(_RC) + call metadata_utils%create(basic_metadata,trim(filename)) + num_times = metadata_utils%get_dimension("time",_RC) + allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) + if (metadata_utils%is_var_present("longitude")) then + call formatter%get_var("longitude",trajectory%lons,_RC) + end if + if (metadata_utils%is_var_present("latitude")) then + call formatter%get_var("latitude",trajectory%lats,_RC) + end if + else + i=index(nc_longitude, '/') + if( i > 0 ) then + grp_name = nc_latitude(1:i-1) + else + grp_name = '' + _FAIL('lat/lon name wo grp_name not implemented in iodaSampler from_config') + endif + var_name_lat = nc_latitude(i+1:) + var_name_lon = nc_longitude(i+1:) + var_name_time= nc_time(i+1:) + this%var_name_lat = var_name_lat + this%var_name_lon = var_name_lon + this%var_name_time= var_name_time + + call formatter%open(trim(filename),pFIO_READ,_RC) + basic_metadata = formatter%read(_RC) + call metadata_utils%create(basic_metadata,trim(filename)) + num_times = metadata%get_dimension(trim(nc_index),_RC) + len = num_times + ncid0=formatter%ncid + call check_nc_status(nf90_inq_ncid(ncid0, grp_name, ncid), _RC) + + allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) + call formatter%get_var(var_name_lon, trajectory%lons, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(var_name_lat, trajectory%lats, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(var_name_time, trajectory%times, group_name=grp_name, count=[len], rc=status) + endif + ! check here call metadata%get_time_info(timeVector=trajectory%times,_RC) + call trajectory%sort_arrays_by_time(_RC) + trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,_RC) trajectory%root_locstream = trajectory%locstream_factory%create_locstream(_RC) _RETURN(_SUCCESS) - end function HistoryTrajectory_from_file + end function HistoryTrajectory_from_config subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc) class(HistoryTrajectory), intent(inout) :: this @@ -563,4 +618,31 @@ subroutine reset_times_to_current_day(this,rc) end subroutine reset_times_to_current_day + + subroutine sort_arrays_by_time(this,rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + + character(len=ESMF_MAXSTR) :: tunits + + + + +! allocate( wksp(len) ) +! allocate( iwksp(len) ) +! call sort3(len, this%T_full, this%X_full, this%Y_full, wksp, iwksp) +! write(6,*) 'af get_var: data_real32' +! write(6,*) this%T_full(1:len:5000) +! deallocate (wksp) +! deallocate (iwksp) + + + + _RETURN(_SUCCESS) + + end subroutine get_file_start_time + + + end module HistoryTrajectoryMod From 3bb74d29e86f51bda0609242d62e987d256a0cef Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 12:15:23 -0400 Subject: [PATCH 51/93] ... --- gridcomps/History/MAPL_HistoryGridComp.F90 | 2 +- .../History/MAPL_HistoryTrajectoryMod.F90 | 73 +++++++++++-------- 2 files changed, 44 insertions(+), 31 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 7c4e785c7efa..a9d126657dc3 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2372,7 +2372,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%timeseries_output) then ! list(n)%trajectory = HistoryTrajectory(trim(list(n)%obsFile),_RC) ! call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) - list(n)%trajectory = HistoryTrajectory(cfg,_RC) + list(n)%trajectory = HistoryTrajectory(cfg,string,_RC) call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) elseif (list(n)%sampler_spec == 'station') then diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 0e25fa4ebda0..8f8efe2f12b0 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -73,80 +73,92 @@ module HistoryTrajectoryMod contains - function HistoryTrajectory_from_config(filename,unusable,rc) result(trajectory) - type(HistoryTrajectory) :: trajectory - character(len=*), intent(in) :: filename + function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) + type(HistoryTrajectory) :: traj + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: status + character(len=ESMF_MAXSTR) :: filename type(NetCDF4_FileFormatter) :: formatter type(FileMetadataUtils) :: metadata_utils type(FileMetadata) :: basic_metadata integer :: num_times + integer :: ncid, grpid, ncid0 + integer :: dimid(10), dimlen(10) + integer :: len + character(len=ESMF_MAXSTR) :: grp_name + character(len=ESMF_MAXSTR) :: dim_name(10) + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_time + integer :: i, j + _UNUSED_DUMMY(unusable) !__ nc_info ! - call ESMF_ConfigGetAttribute(config, value=trajectory%obsFile, default="", & + call ESMF_ConfigGetAttribute(config, value=traj%obsFile, default="", & label=trim(string) // 'obs_file:', _RC) - call ESMF_ConfigGetAttribute(config, value=trajectory%nc_index, default="", & + call ESMF_ConfigGetAttribute(config, value=traj%nc_index, default="", & label=trim(string) // 'nc_Index:', _RC) - call ESMF_ConfigGetAttribute(config, value=trajectory%nc_time, default="", & + call ESMF_ConfigGetAttribute(config, value=traj%nc_time, default="", & label=trim(string) // 'nc_Time:', _RC) - call ESMF_ConfigGetAttribute(config, value=trajectory%nc_longitude, default="", & + call ESMF_ConfigGetAttribute(config, value=traj%nc_longitude, default="", & label=trim(string) // 'nc_Longitude:', _RC) - call ESMF_ConfigGetAttribute(config, value=trajectory%nc_latitude, default="", & + call ESMF_ConfigGetAttribute(config, value=traj%nc_latitude, default="", & label=trim(string) // 'nc_Latitude:', _RC) call formatter%open(trim(filename),pFIO_READ,_RC) - if (trajectory%nc_index == '') then + if (traj%nc_index == '') then basic_metadata = formatter%read(_RC) call metadata_utils%create(basic_metadata,trim(filename)) num_times = metadata_utils%get_dimension("time",_RC) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) + allocate(traj%lons(num_times),traj%lats(num_times),_STAT) if (metadata_utils%is_var_present("longitude")) then - call formatter%get_var("longitude",trajectory%lons,_RC) + call formatter%get_var("longitude",traj%lons,_RC) end if if (metadata_utils%is_var_present("latitude")) then - call formatter%get_var("latitude",trajectory%lats,_RC) + call formatter%get_var("latitude",traj%lats,_RC) end if else - i=index(nc_longitude, '/') + i=index(traj%nc_longitude, '/') if( i > 0 ) then - grp_name = nc_latitude(1:i-1) + grp_name = traj%nc_longitude(1:i-1) else grp_name = '' _FAIL('lat/lon name wo grp_name not implemented in iodaSampler from_config') endif - var_name_lat = nc_latitude(i+1:) - var_name_lon = nc_longitude(i+1:) - var_name_time= nc_time(i+1:) - this%var_name_lat = var_name_lat - this%var_name_lon = var_name_lon - this%var_name_time= var_name_time + var_name_lat = traj%nc_latitude(i+1:) + var_name_lon = traj%nc_longitude(i+1:) + var_name_time= traj%nc_time(i+1:) + traj%var_name_lat = var_name_lat + traj%var_name_lon = var_name_lon + traj%var_name_time= var_name_time call formatter%open(trim(filename),pFIO_READ,_RC) basic_metadata = formatter%read(_RC) call metadata_utils%create(basic_metadata,trim(filename)) - num_times = metadata%get_dimension(trim(nc_index),_RC) + num_times = metadata_utils%get_dimension(trim(nc_index),_RC) len = num_times ncid0=formatter%ncid call check_nc_status(nf90_inq_ncid(ncid0, grp_name, ncid), _RC) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) - call formatter%get_var(var_name_lon, trajectory%lons, group_name=grp_name, count=[len], rc=status) - call formatter%get_var(var_name_lat, trajectory%lats, group_name=grp_name, count=[len], rc=status) - call formatter%get_var(var_name_time, trajectory%times, group_name=grp_name, count=[len], rc=status) + allocate(traj%lons(num_times),traj%lats(num_times),_STAT) + call formatter%get_var(var_name_lon, traj%lons, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(var_name_lat, traj%lats, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(var_name_time, traj%times, group_name=grp_name, count=[len], rc=status) endif ! check here - call metadata%get_time_info(timeVector=trajectory%times,_RC) - call trajectory%sort_arrays_by_time(_RC) + call metadata%get_time_info(timeVector=traj%times,_RC) + call traj%sort_arrays_by_time(_RC) - trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,_RC) - trajectory%root_locstream = trajectory%locstream_factory%create_locstream(_RC) + traj%locstream_factory = LocStreamFactory(traj%lons,traj%lats,_RC) + traj%root_locstream = traj%locstream_factory%create_locstream(_RC) _RETURN(_SUCCESS) @@ -627,7 +639,8 @@ subroutine sort_arrays_by_time(this,rc) character(len=ESMF_MAXSTR) :: tunits - + len = size (this%lons) + ! allocate( wksp(len) ) ! allocate( iwksp(len) ) From 9b18cac17dcac4e057ff316ba7214772665756cf Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 30 Jun 2023 13:14:26 -0400 Subject: [PATCH 52/93] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 75f7698f9a12..d457b37d62fb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Convert ExtData to use ESMF HConfig for YAML parsing rather than YaFYAML - Add StationSamplerMod for station sampler - Added ReplaceMetadata message and method to replace oserver's metadata - Added field utilities to perform basic numeric operations on fields From 55ecc52ffe8636ac7ffa4d7a49bdf0f0ed9a68b5 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 30 Jun 2023 13:57:59 -0400 Subject: [PATCH 53/93] remove no longer needed gfortran ifdef --- gridcomps/ExtData2G/ExtDataConfig.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index 3543d014ebc9..d6ed815ece2f 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -158,9 +158,6 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ ext_config%debug = ESMF_HConfigAsI4(input_config,keyString="debug",_RC) end if -#ifdef __GFORTRAN__ - end associate -#endif _RETURN(_SUCCESS) end subroutine new_ExtDataConfig_from_yaml From 4536e8513a5bb73653f0acfd3ad56221b093ba9f Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 15:35:20 -0600 Subject: [PATCH 54/93] after sorting time, MAPL_HistoryTrajectoryMod.F90 can run through with HGC --- .../History/MAPL_HistoryTrajectoryMod.F90 | 134 +++++++++++++----- 1 file changed, 101 insertions(+), 33 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 8f8efe2f12b0..dca94e88a289 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -15,6 +15,8 @@ module HistoryTrajectoryMod use MAPL_VerticalDataMod use MAPL_BaseMod use MAPL_CommsMod + use MAPL_SortMod + use MAPL_NetCDF use MAPL_LocstreamRegridderMod use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 @@ -28,6 +30,7 @@ module HistoryTrajectoryMod type(ESMF_LocStream) :: root_locstream,dist_locstream type(LocStreamFactory) :: locstream_factory type(ESMF_Time), allocatable :: times(:) + real(kind=REAL64), allocatable :: times_R8(:) real(kind=REAL64), allocatable :: lons(:),lats(:) type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle @@ -51,7 +54,7 @@ module HistoryTrajectoryMod character(len=ESMF_MAXSTR) :: var_name_time character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_lon - character(len=ESMF_MAXSTR) :: tunit + character(len=ESMF_MAXSTR) :: datetime_units contains procedure :: initialize procedure :: create_variable @@ -65,6 +68,8 @@ module HistoryTrajectoryMod procedure :: get procedure :: reset_times_to_current_day procedure :: sort_arrays_by_time + procedure :: time_real_to_ESMF + end type interface HistoryTrajectory @@ -85,7 +90,7 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) type(NetCDF4_FileFormatter) :: formatter type(FileMetadataUtils) :: metadata_utils type(FileMetadata) :: basic_metadata - integer :: num_times + integer(ESMF_KIND_I8) :: num_times integer :: ncid, grpid, ncid0 integer :: dimid(10), dimlen(10) @@ -102,7 +107,7 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) !__ nc_info ! call ESMF_ConfigGetAttribute(config, value=traj%obsFile, default="", & - label=trim(string) // 'obs_file:', _RC) + label=trim(string) // 'track_file:', _RC) call ESMF_ConfigGetAttribute(config, value=traj%nc_index, default="", & label=trim(string) // 'nc_Index:', _RC) call ESMF_ConfigGetAttribute(config, value=traj%nc_time, default="", & @@ -111,7 +116,13 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) label=trim(string) // 'nc_Longitude:', _RC) call ESMF_ConfigGetAttribute(config, value=traj%nc_latitude, default="", & label=trim(string) // 'nc_Latitude:', _RC) + ! + ! bug + traj%datetime_units = "seconds since 1970-01-01 00:00:00" + traj%datetime_units = "seconds since 1970-01-01T00:00:00Z" + + filename=trim(traj%obsFile) call formatter%open(trim(filename),pFIO_READ,_RC) if (traj%nc_index == '') then basic_metadata = formatter%read(_RC) @@ -124,6 +135,7 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) if (metadata_utils%is_var_present("latitude")) then call formatter%get_var("latitude",traj%lats,_RC) end if + call metadata_utils%get_time_info(timeVector=traj%times,_RC) else i=index(traj%nc_longitude, '/') if( i > 0 ) then @@ -132,31 +144,42 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) grp_name = '' _FAIL('lat/lon name wo grp_name not implemented in iodaSampler from_config') endif - var_name_lat = traj%nc_latitude(i+1:) - var_name_lon = traj%nc_longitude(i+1:) - var_name_time= traj%nc_time(i+1:) - traj%var_name_lat = var_name_lat - traj%var_name_lon = var_name_lon - traj%var_name_time= var_name_time + + traj%var_name_lat = traj%nc_latitude(i+1:) + traj%var_name_lon = traj%nc_longitude(i+1:) + traj%var_name_time= traj%nc_time(i+1:) call formatter%open(trim(filename),pFIO_READ,_RC) basic_metadata = formatter%read(_RC) call metadata_utils%create(basic_metadata,trim(filename)) - num_times = metadata_utils%get_dimension(trim(nc_index),_RC) + num_times = basic_metadata%get_dimension(trim(traj%nc_index),_RC) len = num_times - ncid0=formatter%ncid - call check_nc_status(nf90_inq_ncid(ncid0, grp_name, ncid), _RC) + !!status = nf90_inq_ncid(formatter%ncid, group_name, ncid) + !!_ASSERT(status == 0, 'Subgroup not found.') + + allocate(traj%lons(len),traj%lats(len),_STAT) + allocate(traj%times_R8(len),traj%times(len),_STAT) + call formatter%get_var(traj%var_name_lon, traj%lons, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(traj%var_name_lat, traj%lats, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(traj%var_name_time, traj%times_R8, group_name=grp_name, count=[len], rc=status) + + call traj%sort_arrays_by_time(_RC) + call traj%time_real_to_ESMF(_RC) + + ! convert to ESMF + print*, __FILE__, __LINE__ + print*, trim(traj%obsFile) + print*, trim(traj%nc_latitude) + print*, trim(traj%nc_index) + print*, 'grp_name:', trim(grp_name) + print*, 'var_name_lat', traj%var_name_lat + print*, 'var_name_time', traj%var_name_time + print *, 'af sort traj%times_R8' + print*, 'traj%times_R8', traj%times_R8(1:1000:200) - allocate(traj%lons(num_times),traj%lats(num_times),_STAT) - call formatter%get_var(var_name_lon, traj%lons, group_name=grp_name, count=[len], rc=status) - call formatter%get_var(var_name_lat, traj%lats, group_name=grp_name, count=[len], rc=status) - call formatter%get_var(var_name_time, traj%times, group_name=grp_name, count=[len], rc=status) endif - ! check here - call metadata%get_time_info(timeVector=traj%times,_RC) - call traj%sort_arrays_by_time(_RC) - + traj%locstream_factory = LocStreamFactory(traj%lons,traj%lats,_RC) traj%root_locstream = traj%locstream_factory%create_locstream(_RC) @@ -638,24 +661,69 @@ subroutine sort_arrays_by_time(this,rc) character(len=ESMF_MAXSTR) :: tunits + integer :: i, len + integer, allocatable :: IA(:) + real(ESMF_KIND_R8), allocatable :: X(:), Y(:) + integer(ESMF_KIND_I8), allocatable :: IX(:) - len = size (this%lons) - - -! allocate( wksp(len) ) -! allocate( iwksp(len) ) -! call sort3(len, this%T_full, this%X_full, this%Y_full, wksp, iwksp) -! write(6,*) 'af get_var: data_real32' -! write(6,*) this%T_full(1:len:5000) -! deallocate (wksp) -! deallocate (iwksp) - +!--- failed: +! allocate (X, source=this%times_R8) +! allocate (Y, source=this%lons) +! call MAPL_Sort(X, Y) +! + len = size (this%times_R8) + allocate (IA(len), IX(len), X(len)) + do i=1, len + IX(i)=this%times_R8(i) + IA(i)=i + enddo + call MAPL_Sort(IX,IA) + + X = this%lons + do i=1, len + this%lons(i) = X(IA(i)) + enddo + X = this%lats + do i=1, len + this%lats(i) = X(IA(i)) + enddo + X = this%times_R8 + do i=1, len + this%times_R8(i) = X(IA(i)) + enddo + print*, 'IA:', IA(1:100:5) _RETURN(_SUCCESS) + + end subroutine sort_arrays_by_time - end subroutine get_file_start_time - + subroutine time_real_to_ESMF (this,rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + + integer :: i, len + integer :: int_time + type(ESMF_TimeInterval) :: interval + type(ESMF_Time) :: time0 + type(ESMF_Time) :: time1 + character(len=:), allocatable :: tunit + character(len=ESMF_MAXSTR) :: datetime_units + + datetime_units = this%datetime_units + len = size (this%times_R8) + + do i=1, len + int_time = this%times_R8(i) + call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, time0, time1=time1, tunit=tunit, _RC) + this%times(i) = time1 + enddo + + _RETURN(_SUCCESS) + + end subroutine time_real_to_ESMF + end module HistoryTrajectoryMod From 1d472e205f6ae2883497ead3002c6512d8329ad0 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 16:27:40 -0600 Subject: [PATCH 55/93] . --- gridcomps/History/MAPL_HistoryCollection.F90 | 4 - .../History/MAPL_HistoryTrajectoryMod.F90 | 77 +++++++------------ 2 files changed, 26 insertions(+), 55 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index b40aa657aa92..d6b3ca0815b0 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -112,10 +112,6 @@ module MAPL_HistoryCollectionMod character(len=ESMF_MAXSTR) :: sampler_spec = "" character(len=ESMF_MAXSTR) :: positive type(HistoryCollectionGlobalAttributes) :: global_atts - character(len=ESMF_MAXSTR) :: nc_index - character(len=ESMF_MAXSTR) :: nc_time - character(len=ESMF_MAXSTR) :: nc_latitude - character(len=ESMF_MAXSTR) :: nc_longitude contains procedure :: AddGrid end type HistoryCollection diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index dca94e88a289..93203e23a461 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -30,7 +30,7 @@ module HistoryTrajectoryMod type(ESMF_LocStream) :: root_locstream,dist_locstream type(LocStreamFactory) :: locstream_factory type(ESMF_Time), allocatable :: times(:) - real(kind=REAL64), allocatable :: times_R8(:) + real(kind=REAL64), allocatable :: times_R8(:) real(kind=REAL64), allocatable :: lons(:),lats(:) type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle @@ -79,6 +79,7 @@ module HistoryTrajectoryMod contains function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) + use pflogger, only : Logger, logging type(HistoryTrajectory) :: traj type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: string @@ -86,7 +87,7 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: filename + character(len=ESMF_MAXSTR) :: filename type(NetCDF4_FileFormatter) :: formatter type(FileMetadataUtils) :: metadata_utils type(FileMetadata) :: basic_metadata @@ -95,17 +96,16 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) integer :: ncid, grpid, ncid0 integer :: dimid(10), dimlen(10) integer :: len + integer :: i character(len=ESMF_MAXSTR) :: grp_name character(len=ESMF_MAXSTR) :: dim_name(10) character(len=ESMF_MAXSTR) :: var_name_lon character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_time - integer :: i, j + type(Logger), pointer :: lgr _UNUSED_DUMMY(unusable) - !__ nc_info - ! call ESMF_ConfigGetAttribute(config, value=traj%obsFile, default="", & label=trim(string) // 'track_file:', _RC) call ESMF_ConfigGetAttribute(config, value=traj%nc_index, default="", & @@ -116,12 +116,9 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) label=trim(string) // 'nc_Longitude:', _RC) call ESMF_ConfigGetAttribute(config, value=traj%nc_latitude, default="", & label=trim(string) // 'nc_Latitude:', _RC) - ! - ! bug - traj%datetime_units = "seconds since 1970-01-01 00:00:00" - traj%datetime_units = "seconds since 1970-01-01T00:00:00Z" - + traj%datetime_units = "seconds since 1970-01-01 00:00:00" + filename=trim(traj%obsFile) call formatter%open(trim(filename),pFIO_READ,_RC) if (traj%nc_index == '') then @@ -138,13 +135,8 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) call metadata_utils%get_time_info(timeVector=traj%times,_RC) else i=index(traj%nc_longitude, '/') - if( i > 0 ) then - grp_name = traj%nc_longitude(1:i-1) - else - grp_name = '' - _FAIL('lat/lon name wo grp_name not implemented in iodaSampler from_config') - endif - + _ASSERT (i>0, 'group name not found') + grp_name = traj%nc_longitude(1:i-1) traj%var_name_lat = traj%nc_latitude(i+1:) traj%var_name_lon = traj%nc_longitude(i+1:) traj%var_name_time= traj%nc_time(i+1:) @@ -154,11 +146,9 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) call metadata_utils%create(basic_metadata,trim(filename)) num_times = basic_metadata%get_dimension(trim(traj%nc_index),_RC) len = num_times - !!status = nf90_inq_ncid(formatter%ncid, group_name, ncid) - !!_ASSERT(status == 0, 'Subgroup not found.') - + allocate(traj%lons(len),traj%lats(len),_STAT) - allocate(traj%times_R8(len),traj%times(len),_STAT) + allocate(traj%times_R8(len),traj%times(len),_STAT) call formatter%get_var(traj%var_name_lon, traj%lons, group_name=grp_name, count=[len], rc=status) call formatter%get_var(traj%var_name_lat, traj%lats, group_name=grp_name, count=[len], rc=status) call formatter%get_var(traj%var_name_time, traj%times_R8, group_name=grp_name, count=[len], rc=status) @@ -166,20 +156,17 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) call traj%sort_arrays_by_time(_RC) call traj%time_real_to_ESMF(_RC) - ! convert to ESMF - print*, __FILE__, __LINE__ - print*, trim(traj%obsFile) - print*, trim(traj%nc_latitude) - print*, trim(traj%nc_index) - print*, 'grp_name:', trim(grp_name) - print*, 'var_name_lat', traj%var_name_lat - print*, 'var_name_time', traj%var_name_time - print *, 'af sort traj%times_R8' - print*, 'traj%times_R8', traj%times_R8(1:1000:200) - + lgr => logging%get_logger('HISTORY.sampler') + call lgr%debug('%a %a', trim(traj%obsFile)) + call lgr%debug('%a %a', trim(traj%nc_index)) + call lgr%debug('%a %a', trim(traj%nc_latitude)) + call lgr%debug('%a %a', 'grp_name:', trim(grp_name)) + call lgr%debug('%a %a', 'var_name_lat', traj%var_name_lat) + call lgr%debug('%a %a', 'var_name_time', traj%var_name_time) + ! call lgr%debug('%a %f10.1 %f10.1 %f10.1', 'done sort: traj%times_R8', traj%times_R8(1:20:10)) + call lgr%debug('%a %f10.1', 'done sort: traj%times_R8', traj%times_R8(1)) endif - traj%locstream_factory = LocStreamFactory(traj%lons,traj%lats,_RC) traj%root_locstream = traj%locstream_factory%create_locstream(_RC) @@ -659,24 +646,16 @@ subroutine sort_arrays_by_time(this,rc) integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: tunits - - integer :: i, len + integer :: i, len integer, allocatable :: IA(:) real(ESMF_KIND_R8), allocatable :: X(:), Y(:) integer(ESMF_KIND_I8), allocatable :: IX(:) -!--- failed: -! allocate (X, source=this%times_R8) -! allocate (Y, source=this%lons) -! call MAPL_Sort(X, Y) -! - len = size (this%times_R8) - allocate (IA(len), IX(len), X(len)) + allocate (IA(len), IX(len), X(len)) do i=1, len IX(i)=this%times_R8(i) - IA(i)=i + IA(i)=i enddo call MAPL_Sort(IX,IA) @@ -693,9 +672,7 @@ subroutine sort_arrays_by_time(this,rc) this%times_R8(i) = X(IA(i)) enddo - print*, 'IA:', IA(1:100:5) _RETURN(_SUCCESS) - end subroutine sort_arrays_by_time @@ -705,13 +682,13 @@ subroutine time_real_to_ESMF (this,rc) integer :: status integer :: i, len - integer :: int_time + integer :: int_time type(ESMF_TimeInterval) :: interval type(ESMF_Time) :: time0 type(ESMF_Time) :: time1 character(len=:), allocatable :: tunit character(len=ESMF_MAXSTR) :: datetime_units - + datetime_units = this%datetime_units len = size (this%times_R8) @@ -720,10 +697,8 @@ subroutine time_real_to_ESMF (this,rc) call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, time0, time1=time1, tunit=tunit, _RC) this%times(i) = time1 enddo - + _RETURN(_SUCCESS) - end subroutine time_real_to_ESMF - end module HistoryTrajectoryMod From fa4736a48c7bd81847c16660fe45bbbb024588cf Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 17:25:38 -0600 Subject: [PATCH 56/93] . --- gridcomps/History/MAPL_HistoryGridComp.F90 | 2 -- gridcomps/History/MAPL_HistoryTrajectoryMod.F90 | 12 +----------- 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index a9d126657dc3..5704080a8b81 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2370,8 +2370,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then -! list(n)%trajectory = HistoryTrajectory(trim(list(n)%obsFile),_RC) -! call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) list(n)%trajectory = HistoryTrajectory(cfg,string,_RC) call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 93203e23a461..4ccbe9f5dac3 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -79,7 +79,7 @@ module HistoryTrajectoryMod contains function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) - use pflogger, only : Logger, logging + use pflogger, only : Logger, logging type(HistoryTrajectory) :: traj type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: string @@ -155,16 +155,6 @@ function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) call traj%sort_arrays_by_time(_RC) call traj%time_real_to_ESMF(_RC) - - lgr => logging%get_logger('HISTORY.sampler') - call lgr%debug('%a %a', trim(traj%obsFile)) - call lgr%debug('%a %a', trim(traj%nc_index)) - call lgr%debug('%a %a', trim(traj%nc_latitude)) - call lgr%debug('%a %a', 'grp_name:', trim(grp_name)) - call lgr%debug('%a %a', 'var_name_lat', traj%var_name_lat) - call lgr%debug('%a %a', 'var_name_time', traj%var_name_time) - ! call lgr%debug('%a %f10.1 %f10.1 %f10.1', 'done sort: traj%times_R8', traj%times_R8(1:20:10)) - call lgr%debug('%a %f10.1', 'done sort: traj%times_R8', traj%times_R8(1)) endif traj%locstream_factory = LocStreamFactory(traj%lons,traj%lats,_RC) From b77b7dcdaa7701eedb3c867c1a41cb9fa81faf8b Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 30 Jun 2023 17:34:27 -0600 Subject: [PATCH 57/93] add CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 75f7698f9a12..f5e59603436c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,7 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). ## [Unreleased] - +- sampling IODA file with trajectory sampler (step-1): make it run ### Added - Add StationSamplerMod for station sampler From d81027fff068ce75570bf4ad270c7625891be52a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 3 Jul 2023 10:28:08 -0400 Subject: [PATCH 58/93] Require ESMF 8.5.0 and 8.5.0b22 at least --- CHANGELOG.md | 5 ++++- CMakeLists.txt | 26 +++++++++++++++++++++++++- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1306555bffe6..a76bc3235cb7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,10 +6,13 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). ## [Unreleased] -- sampling IODA file with trajectory sampler (step-1): make it run + ### Added +- sampling IODA file with trajectory sampler (step-1): make it run - Convert ExtData to use ESMF HConfig for YAML parsing rather than YaFYAML + - Set required ESMF version to 8.5.0 + - Add check in CMake to make sure ESMF version is at least 8.5.0b22 if using a beta snapshot - Add StationSamplerMod for station sampler - Added ReplaceMetadata message and method to replace oserver's metadata - Added field utilities to perform basic numeric operations on fields diff --git a/CMakeLists.txt b/CMakeLists.txt index 3481b0063d0d..dee24138bdad 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -142,7 +142,7 @@ if (NOT Baselibs_FOUND) endif() if (NOT TARGET esmf) - find_package(ESMF 8.4.0 MODULE REQUIRED) + find_package(ESMF 8.5.0 MODULE REQUIRED) # ESMF as used in MAPL requires MPI # NOTE: This looks odd because some versions of FindESMF.cmake out in the @@ -159,6 +159,30 @@ if (NOT Baselibs_FOUND) endif () endif () +# Due to use of a feature of ESMF that came in with ESMF v8.5.0b22, +# a beta version of ESMF, we need to make sure that if we are using +# ESMF 8.5.0, that we are using at least ESMF 8.5.0b22. This is +# a temporary fix until ESMF 8.5.0 final is released. Our criterion are: +# 1. ESMF version is 8.5.0 (from ESMF_VERSION) +# 2. We are using a beta snapshot of ESMF (from ESMF_BETA_RELEASE) +# 3. The ESMF version is at least v8.5.0b22 (from ESMF_BETA_SNAPSHOT) + +if (ESMF_VERSION VERSION_EQUAL 8.5.0 AND ESMF_BETA_RELEASE) + # So now we are using a beta version of ESMF 8.5.0. We need to make sure + # that the version is at least 8.5.0b22. That version information + # is stored in ESMF_BETA_SNAPSHOT and is of the form "v8.5.0b22" + set (ESMF_BETA_SNAPSHOT_TARGET 22) + string(REGEX REPLACE "v8.5.0b([0-9]+)" "\\1" ESMF_BETA_SNAPSHOT_NUMBER ${ESMF_BETA_SNAPSHOT}) + if (ESMF_BETA_SNAPSHOT_NUMBER LESS ESMF_BETA_SNAPSHOT_TARGET) + message(FATAL_ERROR + "ERROR! ESMF version must be at least v8.5.0b22, but you are using ${ESMF_BETA_SNAPSHOT}\n" + "" + "This is due to the use of a feature of ESMF that came in with ESMF v8.5.0b22, a beta version of ESMF.\n" + "This is a temporary fix until stable ESMF 8.5.0 is released.\n" + ) + endif () +endif () + # We wish to add extra flags when compiling as Debug. We should only # do this if we are using esma_cmake since the flags are defined # there. Note that some flags like STANDARD_F18 might be available on From 070888b601494f260967aab2fc42671ecd847d37 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 3 Jul 2023 10:39:12 -0400 Subject: [PATCH 59/93] Add ESMF_VERSION check for Baselibs builds --- CMakeLists.txt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index dee24138bdad..9a403a3d72bd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -157,6 +157,13 @@ if (NOT Baselibs_FOUND) add_library(esmf ALIAS ESMF) endif() endif () +else () + # This is an ESMF version test when using Baselibs which doesn't use the + # same find_package internally in ESMA_cmake as used above (with a version + # number) so this lets us at least trap use of old Baselibs here. + if (ESMF_VERSION VERSION_LESS 8.5.0) + message(FATAL_ERROR "ESMF must be at least 8.5.0") + endif () endif () # Due to use of a feature of ESMF that came in with ESMF v8.5.0b22, From 2c75a209461825fe2a583b72ff636f0bdf9d792e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 5 Jul 2023 09:21:23 -0400 Subject: [PATCH 60/93] Updates to build with Spack instead of Baselibs --- CMakeLists.txt | 5 +- cmake/FindESMF.cmake | 138 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+), 2 deletions(-) create mode 100644 cmake/FindESMF.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a403a3d72bd..081e95dc2d29 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -58,6 +58,8 @@ if (NOT COMMAND esma) endif () +list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") + option (BUILD_SHARED_MAPL "Build shared MAPL libraries" ON) if (BUILD_SHARED_MAPL) set (MAPL_LIBRARY_TYPE SHARED) @@ -119,7 +121,7 @@ if (BUILD_WITH_PFLOGGER) endif() endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () @@ -250,7 +252,6 @@ if (PFUNIT_FOUND) endif () # Support for automated code generation -list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") include(mapl_acg) include(mapl_create_stub_component) add_subdirectory (Apps) diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake new file mode 100644 index 000000000000..161654428d88 --- /dev/null +++ b/cmake/FindESMF.cmake @@ -0,0 +1,138 @@ +# - Try to find ESMF +# +# Uses ESMFMKFILE to find the filepath of esmf.mk. If this is NOT set, then this +# module will attempt to find esmf.mk. If ESMFMKFILE exists, then +# ESMF_FOUND=TRUE and all ESMF makefile variables will be set in the global +# scope. Optionally, set ESMF_MKGLOBALS to a string list to filter makefile +# variables. For example, to globally scope only ESMF_LIBSDIR and ESMF_APPSDIR +# variables, use this CMake command in CMakeLists.txt: +# +# set(ESMF_MKGLOBALS "LIBSDIR" "APPSDIR") + +# Set ESMFMKFILE as defined by system env variable. If it's not explicitly set +# try to find esmf.mk file in default locations (ESMF_ROOT, CMAKE_PREFIX_PATH, +# etc) +if(NOT DEFINED ESMFMKFILE) + if(NOT DEFINED ENV{ESMFMKFILE}) + find_path(ESMFMKFILE_PATH esmf.mk PATH_SUFFIXES lib lib64) + if(ESMFMKFILE_PATH) + set(ESMFMKFILE ${ESMFMKFILE_PATH}/esmf.mk) + message(STATUS "Found esmf.mk file ${ESMFMKFILE}") + endif() + else() + set(ESMFMKFILE $ENV{ESMFMKFILE}) + endif() +endif() + +# Only parse the mk file if it is found +if(EXISTS ${ESMFMKFILE}) + set(ESMFMKFILE ${ESMFMKFILE} CACHE FILEPATH "Path to esmf.mk file") + set(ESMF_FOUND TRUE CACHE BOOL "esmf.mk file found" FORCE) + + # Read the mk file + file(STRINGS "${ESMFMKFILE}" esmfmkfile_contents) + # Parse each line in the mk file + foreach(str ${esmfmkfile_contents}) + # Only consider uncommented lines + string(REGEX MATCH "^[^#]" def ${str}) + # Line is not commented + if(def) + # Extract the variable name + string(REGEX MATCH "^[^=]+" esmf_varname ${str}) + # Extract the variable's value + string(REGEX MATCH "=.+$" esmf_vardef ${str}) + # Only for variables with a defined value + if(esmf_vardef) + # Get rid of the assignment string + string(SUBSTRING ${esmf_vardef} 1 -1 esmf_vardef) + # Remove whitespace + string(STRIP ${esmf_vardef} esmf_vardef) + # A string or single-valued list + if(NOT DEFINED ESMF_MKGLOBALS) + # Set in global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in GUI + mark_as_advanced(esmf_varname) + else() # Need to filter global promotion + foreach(m ${ESMF_MKGLOBALS}) + string(FIND ${esmf_varname} ${m} match) + # Found the string + if(NOT ${match} EQUAL -1) + # Promote to global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in the GUI + mark_as_advanced(esmf_varname) + # No need to search for the current string filter + break() + endif() + endforeach() + endif() + endif() + endif() + endforeach() + + # Construct ESMF_VERSION from ESMF_VERSION_STRING_GIT + # ESMF_VERSION_MAJOR and ESMF_VERSION_MINOR are defined in ESMFMKFILE + set(ESMF_VERSION 0) + set(ESMF_VERSION_PATCH ${ESMF_VERSION_REVISION}) + set(ESMF_BETA_RELEASE FALSE) + if(ESMF_VERSION_BETASNAPSHOT MATCHES "^('T')$") + set(ESMF_BETA_RELEASE TRUE) + if(ESMF_VERSION_STRING_GIT MATCHES "^ESMF.*beta_snapshot") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + elseif(ESMF_VERSION_STRING_GIT MATCHES "^v.\..\..b") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + else() + set(ESMF_BETA_SNAPSHOT 0) + endif() + message(STATUS "Detected ESMF Beta snapshot: ${ESMF_BETA_SNAPSHOT}") + endif() + set(ESMF_VERSION "${ESMF_VERSION_MAJOR}.${ESMF_VERSION_MINOR}.${ESMF_VERSION_PATCH}") + + # Find the ESMF library + if(USE_ESMF_STATIC_LIBS) + find_library(ESMF_LIBRARY_LOCATION NAMES libesmf.a PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "Static ESMF library (libesmf.a) not found in \ + ${ESMF_LIBSDIR}. Try setting USE_ESMF_STATIC_LIBS=OFF") + endif() + add_library(ESMF STATIC IMPORTED) + else() + find_library(ESMF_LIBRARY_LOCATION NAMES esmf PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "ESMF library not found in ${ESMF_LIBSDIR}.") + endif() + add_library(ESMF UNKNOWN IMPORTED) + endif() + + # Add ESMF include directories + set(ESMF_INCLUDE_DIRECTORIES "") + separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) + foreach(_ITEM ${_ESMF_F90COMPILEPATHS}) + string(REGEX REPLACE "^-I" "" _ITEM "${_ITEM}") + list(APPEND ESMF_INCLUDE_DIRECTORIES ${_ITEM}) + endforeach() + + # Add ESMF link libraries + string(STRIP "${ESMF_F90LINKRPATHS} ${ESMF_F90ESMFLINKRPATHS} ${ESMF_F90ESMFLINKPATHS} ${ESMF_F90LINKPATHS} ${ESMF_F90LINKLIBS} ${ESMF_F90LINKOPTS}" ESMF_INTERFACE_LINK_LIBRARIES) + + # Finalize find_package + include(FindPackageHandleStandardArgs) + + find_package_handle_standard_args( + ${CMAKE_FIND_PACKAGE_NAME} + REQUIRED_VARS ESMF_LIBRARY_LOCATION + ESMF_INTERFACE_LINK_LIBRARIES + ESMF_F90COMPILEPATHS + VERSION_VAR ESMF_VERSION) + + set_target_properties(ESMF PROPERTIES + IMPORTED_LOCATION "${ESMF_LIBRARY_LOCATION}" + INTERFACE_INCLUDE_DIRECTORIES "${ESMF_INCLUDE_DIRECTORIES}" + INTERFACE_LINK_LIBRARIES "${ESMF_INTERFACE_LINK_LIBRARIES}") + +else() + set(ESMF_FOUND FALSE CACHE BOOL "esmf.mk file NOT found" FORCE) + message(WARNING "ESMFMKFILE ${ESMFMKFILE} not found. Try setting ESMFMKFILE \ + to esmf.mk location.") +endif() From 977bc2136d9fd396efcf8679f730d619f10730ad Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 6 Jul 2023 11:43:56 -0400 Subject: [PATCH 61/93] Fixes for fargparse use in CMake --- CHANGELOG.md | 2 ++ CMakeLists.txt | 2 +- Tests/CMakeLists.txt | 11 +++-------- gridcomps/Cap/CMakeLists.txt | 4 ---- 4 files changed, 6 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a76bc3235cb7..1bab7b6ac937 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -44,12 +44,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Created cubed-sphere grid factory with files split by face - Removed unneeded and confusing default in History Grid Comp (see #2081) +- Fixes in CMake for fArgParse transition ### Removed ### Deprecated - Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 + - Set option `BUILD_WITH_FLAP` to default `OFF` ## [2.39.4] - 2023-06-23 diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a403a3d72bd..663f5a9008eb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -119,7 +119,7 @@ if (BUILD_WITH_PFLOGGER) endif() endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () diff --git a/Tests/CMakeLists.txt b/Tests/CMakeLists.txt index 89bfe936b11b..d427e82a59c0 100644 --- a/Tests/CMakeLists.txt +++ b/Tests/CMakeLists.txt @@ -8,10 +8,10 @@ set (srcs VarspecDescription.F90 ) -if (BUILD_WITH_FLAP) +if (BUILD_WITH_FARGPARSE) ecbuild_add_executable (TARGET ExtDataDriver.x SOURCES ${srcs}) - target_link_libraries (ExtDataDriver.x PRIVATE MAPL FLAP::FLAP esmf) + target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse esmf) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(ExtDataDriver.x PRIVATE OpenMP::OpenMP_Fortran) @@ -21,17 +21,12 @@ if (BUILD_WITH_FLAP) add_subdirectory(ExtData_Testing_Framework EXCLUDE_FROM_ALL) ecbuild_add_executable (TARGET pfio_MAPL_demo.x SOURCES pfio_MAPL_demo.F90) - target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FLAP::FLAP esmf) + target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse esmf) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(pfio_MAPL_demo.x PRIVATE OpenMP::OpenMP_Fortran) endif () set_target_properties(pfio_MAPL_demo.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) - -endif () - -if (BUILD_WITH_FARGPARSE) - ecbuild_add_executable (TARGET MAPL_demo_fargparse.x SOURCES MAPL_demo_fargparse.F90) target_link_libraries (MAPL_demo_fargparse.x PRIVATE MAPL FARGPARSE::fargparse esmf) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/gridcomps/Cap/CMakeLists.txt b/gridcomps/Cap/CMakeLists.txt index 194c41300aaa..c6136b4f63e3 100644 --- a/gridcomps/Cap/CMakeLists.txt +++ b/gridcomps/Cap/CMakeLists.txt @@ -28,9 +28,5 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () target_include_directories (${this} PUBLIC $) -if (BUILD_WITH_FLAP) - target_compile_definitions (${this} PRIVATE USE_FLAP) -endif() - set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) From 8cbf3f901610f53e14f3407c10b49d106ae01e75 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 6 Jul 2023 12:51:12 -0400 Subject: [PATCH 62/93] We can't turn off flap yet --- CHANGELOG.md | 1 - CMakeLists.txt | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1bab7b6ac937..db1d9ffaedad 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -51,7 +51,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated - Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 - - Set option `BUILD_WITH_FLAP` to default `OFF` ## [2.39.4] - 2023-06-23 diff --git a/CMakeLists.txt b/CMakeLists.txt index 663f5a9008eb..9a403a3d72bd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -119,7 +119,7 @@ if (BUILD_WITH_PFLOGGER) endif() endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () From c344625b14c2060cb2320cb4ad931f5aa012a63b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 6 Jul 2023 13:01:46 -0400 Subject: [PATCH 63/93] Move tutorial build to base on fargparse --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a403a3d72bd..a507df9057b6 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -240,7 +240,7 @@ add_subdirectory (base) add_subdirectory (MAPL) add_subdirectory (gridcomps) add_subdirectory (griddedio) -if (BUILD_WITH_FLAP) +if (BUILD_WITH_FARGPARSE) add_subdirectory (tutorial) endif() From 8ce106ccaebfeb5e863fb7e92aa24692dabb844f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 7 Jul 2023 08:15:50 -0400 Subject: [PATCH 64/93] Temporary action fix for push to dev --- .github/workflows/push-to-develop.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml index fd525b2a4b35..16409a0bf4c9 100644 --- a/.github/workflows/push-to-develop.yml +++ b/.github/workflows/push-to-develop.yml @@ -22,7 +22,10 @@ jobs: target_branch: release/MAPL-v3 label: automatic,MAPL3,Skip Changelog template: .github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md - get_diff: true + # Turning this to false until the action can get a fix for + # https://github.com/devops-infra/action-pull-request/issues/126 + #get_diff: true + get_diff: false assignee: ${{ github.actor }} old_string: "" new_string: ${{ github.event.commits[0].message }} From 5eba4166da4e7444ea8098b5463361ffda7b143b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 12 Jul 2023 08:17:38 -0400 Subject: [PATCH 65/93] Restore FLAP default on for now --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9be60550f8e7..4ebf9ea9effe 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -121,7 +121,7 @@ if (BUILD_WITH_PFLOGGER) endif() endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () From 03184d25aa86b78fd934cc35920d4e38241a1c42 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 12 Jul 2023 08:17:49 -0400 Subject: [PATCH 66/93] Update changelog --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index f5c2fc5d8a81..8693ae3bf1e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,6 +39,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Clean up for TOSS4 changes at NAS - Make the GEOSadas CI build separate as it often fails due to race conditions in GSI - Update CI to use BCs v11.1.0 +- Updates to support building MAPL with spack instead of Baselibs + - Add `FindESMF.cmake` file to `cmake` directory (as it can't easily be found via spack) + - Move `CMAKE_MODULE_PATH` append statement up to find `FindESMF.cmake` before we `find_package(ESMF)` ### Fixed From cbeafcbc1c66d4bb30eccecfcec1c7ee25b81902 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 12 Jul 2023 08:24:04 -0400 Subject: [PATCH 67/93] Turn off FLAP by default, but turn it on with adas build --- .circleci/config.yml | 1 + CHANGELOG.md | 2 ++ CMakeLists.txt | 2 +- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index fe0d9950a295..59e23e5b779b 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -217,6 +217,7 @@ workflows: checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 + extra_cmake_options: "-DBUILD_WITH_FLAP=ON" build-and-publish-docker: when: diff --git a/CHANGELOG.md b/CHANGELOG.md index 8693ae3bf1e9..809a17a14349 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -42,6 +42,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Updates to support building MAPL with spack instead of Baselibs - Add `FindESMF.cmake` file to `cmake` directory (as it can't easily be found via spack) - Move `CMAKE_MODULE_PATH` append statement up to find `FindESMF.cmake` before we `find_package(ESMF)` + - Default `BUILD_WITH_FLAP` to `OFF` as we don't build it in spack + - Explicitly build GEOSadas in CI with `-DBUILD_WITH_FLAP=ON` as GEOSadas is still behind in moving to use fArgParse ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 4ebf9ea9effe..9be60550f8e7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -121,7 +121,7 @@ if (BUILD_WITH_PFLOGGER) endif() endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () From 806957d9d663c10555388608100e102f3b336a7b Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 12 Jul 2023 17:05:38 -0400 Subject: [PATCH 68/93] fixes #2149 --- Tests/ExtDataRoot_GridComp.F90 | 75 ++++++++++++++++++++++++++++------ Tests/VarspecDescription.F90 | 2 + 2 files changed, 64 insertions(+), 13 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 5800b0007045..788f1715ea31 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -66,60 +66,70 @@ subroutine SetServices ( GC, RC ) type(ESMF_Config) :: cf type(SyntheticFieldSupportWrapper) :: synthWrap type(SyntheticFieldSupport), pointer :: synth + logical :: on_tiles + integer :: vloc call ESMF_GridCompGet( GC, NAME=COMP_NAME, CONFIG=CF, _RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize_, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run_, _RC) + call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=on_tiles,_RC) + allocate(synth) synthWrap%ptr => synth call ESMF_UserCompSetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) + if (on_tiles) then + vloc = MAPL_DimsTileOnly + else + vloc = MAPL_DimsHorzOnly + end if call AddState(GC,CF,"IMPORT",_RC) call AddState(GC,CF,"EXPORT",_RC) + call MAPL_AddInternalSpec(GC,& short_name='time', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='lats', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='lons', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='i_index', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='j_index', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='doy', & long_name='day_since_start_of_year' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='rand', & long_name='random number' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) @@ -177,6 +187,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_GridCreate(GC, _RC) call ESMF_GridCompGet(GC, grid=grid, _RC) + call set_locstream(_RC) !allocate(ak(lm+1),stat=status) !allocate(bk(lm+1),stat=status) !call set_eta(lm,ls,ptop,pint,ak,bk) @@ -189,6 +200,30 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ForceAllocation(Export,_RC) _RETURN(ESMF_SUCCESS) + contains + + subroutine set_locstream(rc) + + integer, optional, intent(out) :: rc + + integer :: status + logical :: on_tiles + character(len=ESMF_MAXPATHLEN) :: tile_file + type(ESMF_DistGrid) :: distgrid + type(ESMF_DELayout) :: layout + type(MAPL_LocStream) :: exch + + call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=on_tiles,_RC) + if (on_tiles) then + call ESMF_ConfigGetAttribute(cf,tile_file,label="tiling_file:",_RC) + call ESMF_GridGet(grid,distGrid=distgrid,_RC) + call ESMF_DistGridGet(distgrid,deLayout=layout,_RC) + call MAPL_LocStreamCreate(exch,layout=layout,filename=tile_file, & + name = 'my_tiles', mask = [MAPL_LAND], grid=grid,_RC) + call MAPL_ExchangeGridSet(gc,exch,_RC) + end if + _RETURN(_SUCCESS) + end subroutine set_locstream END SUBROUTINE Initialize_ @@ -437,10 +472,12 @@ subroutine CopyState(inState,outState,rc) integer :: status integer :: I - real, pointer :: IMptr3(:,:,:) => null() - real, pointer :: Exptr3(:,:,:) => null() - real, pointer :: IMptr2(:,:) => null() - real, pointer :: Exptr2(:,:) => null() + real, pointer :: IMptr3(:,:,:) + real, pointer :: Exptr3(:,:,:) + real, pointer :: IMptr2(:,:) + real, pointer :: Exptr2(:,:) + real, pointer :: IMptr1(:) + real, pointer :: Exptr1(:) integer :: itemcountIn,itemCountOut,rank character(len=ESMF_MAXSTR), allocatable :: inNameList(:) character(len=ESMF_MAXSTR), allocatable :: outNameList(:) @@ -462,7 +499,11 @@ subroutine CopyState(inState,outState,rc) call ESMF_StateGet(inState,trim(inNameList(i)),impf,_RC) call ESMF_StateGet(outState,trim(outNameList(i)),expf,_RC) call ESMF_FieldGet(impf,rank=rank,_RC) - if (rank==2) then + if (rank==1) then + call MAPL_GetPointer(inState,IMptr1,inNameList(i),_RC) + call MAPL_GetPointer(outState,Exptr1,inNameList(i),alloc=.true.,_RC) + EXptr1=IMptr1 + else if (rank==2) then call MAPL_GetPointer(inState,IMptr2,inNameList(i),_RC) call MAPL_GetPointer(outState,Exptr2,inNameList(i),alloc=.true.,_RC) EXptr2=IMptr2 @@ -564,6 +605,8 @@ subroutine CompareState(State1,State2,tol,rc) real, pointer :: ptr3_2(:,:,:) real, pointer :: ptr2_1(:,:) real, pointer :: ptr2_2(:,:) + real, pointer :: ptr1_1(:) + real, pointer :: ptr1_2(:) integer :: itemcount,rank1,rank2 character(len=ESMF_MAXSTR), allocatable :: NameList(:) logical, allocatable :: foundDiff(:) @@ -588,7 +631,13 @@ subroutine CompareState(State1,State2,tol,rc) end if _ASSERT(rank1==rank2,'needs informative message') foundDiff(i)=.false. - if (rank1==2) then + if (rank1==1) then + call MAPL_GetPointer(state1,ptr1_1,trim(nameList(i)),_RC) + call MAPL_GetPointer(state2,ptr1_2,trim(nameList(i)),_RC) + if (any((ptr1_1-ptr1_2) > tol)) then + foundDiff(i) = .true. + end if + else if (rank1==2) then call MAPL_GetPointer(state1,ptr2_1,trim(nameList(i)),_RC) call MAPL_GetPointer(state2,ptr2_2,trim(nameList(i)),_RC) if (any((ptr2_1-ptr2_2) > tol)) then diff --git a/Tests/VarspecDescription.F90 b/Tests/VarspecDescription.F90 index 7f08561bd358..499a81d5a9e8 100644 --- a/Tests/VarspecDescription.F90 +++ b/Tests/VarspecDescription.F90 @@ -57,6 +57,8 @@ function new_VarspecDescriptionFromConfig(cf,nwords,rc) result(VarspecDescr) VarspecDescr%dims = MAPL_DimsHorzOnly else if (trim(tmpstring) == 'xyz') then VarspecDescr%dims = MAPL_DimsHorzVert + else if (trim(tmpstring) == 'tileonly') then + VarspecDescr%dims = MAPL_DimsTileOnly end if tmpstring = svec%at(5) if (trim(tmpstring) == 'none') then From 87359aef1f8c41d2024f51186fc43c5821ab0b25 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 14 Jul 2023 10:47:55 -0400 Subject: [PATCH 69/93] don't know what happened --- Tests/ExtDataRoot_GridComp.F90 | 99 +++++++++++++++++++++------------- 1 file changed, 63 insertions(+), 36 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 788f1715ea31..7a5df5a98fe1 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -38,6 +38,7 @@ MODULE ExtDataUtRoot_GridCompMod type(StringStringMap) :: fillDefs character(len=ESMF_MAXSTR) :: runMode type(timeVar) :: tFunc + logical :: on_tiles end type SyntheticFieldSupport type :: SyntheticFieldSupportWrapper @@ -74,13 +75,12 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize_, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run_, _RC) - call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=on_tiles,_RC) - allocate(synth) synthWrap%ptr => synth call ESMF_UserCompSetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) - if (on_tiles) then + call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=synth%on_tiles,_RC) + if (synth%on_tiles) then vloc = MAPL_DimsTileOnly else vloc = MAPL_DimsHorzOnly @@ -163,8 +163,10 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(SyntheticFieldSupportWrapper) :: synthWrap type(SyntheticFieldSupport), pointer :: synth => null() character(len=ESMF_MaxStr) :: key, keyVal + type(MAPL_MetaComp), pointer :: MAPL call ESMF_GridCompGet( GC, name=comp_name, config=CF, _RC ) + call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) @@ -207,20 +209,20 @@ subroutine set_locstream(rc) integer, optional, intent(out) :: rc integer :: status - logical :: on_tiles character(len=ESMF_MAXPATHLEN) :: tile_file type(ESMF_DistGrid) :: distgrid type(ESMF_DELayout) :: layout type(MAPL_LocStream) :: exch - call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=on_tiles,_RC) - if (on_tiles) then + if (synth%on_tiles) then call ESMF_ConfigGetAttribute(cf,tile_file,label="tiling_file:",_RC) call ESMF_GridGet(grid,distGrid=distgrid,_RC) call ESMF_DistGridGet(distgrid,deLayout=layout,_RC) call MAPL_LocStreamCreate(exch,layout=layout,filename=tile_file, & name = 'my_tiles', mask = [MAPL_LAND], grid=grid,_RC) call MAPL_ExchangeGridSet(gc,exch,_RC) + call MAPL_GenericMakeXchgNatural(MAPL,_RC) + call ESMF_GridCompSet(gc,grid=grid,_RC) end if _RETURN(_SUCCESS) end subroutine set_locstream @@ -266,17 +268,19 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) synth => synthWrap%ptr - call ESMF_GridCompGet(GC,grid=grid,_RC) - call MAPL_GetPointer(internal,ptrR4,'lons',_RC) - call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=ptrR8, _RC) - ptrR4=ptrR8 - call MAPL_GetPointer(internal,ptrR4,'lats',_RC) - call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=ptrR8, _RC) - ptrR4=ptrR8 + if (.not. synth%on_tiles) then + call ESMF_GridCompGet(GC,grid=grid,_RC) + call MAPL_GetPointer(internal,ptrR4,'lons',_RC) + call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=ptrR8, _RC) + ptrR4=ptrR8 + call MAPL_GetPointer(internal,ptrR4,'lats',_RC) + call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=ptrR8, _RC) + ptrR4=ptrR8 + end if select case (trim(synth%runMode)) @@ -528,7 +532,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) integer, optional, intent(out) :: rc integer :: status - real, pointer :: Exptr2(:,:) => null() + real, pointer :: Exptr2(:,:), Exptr1(:) integer :: itemcount character(len=ESMF_MAXSTR), allocatable :: outNameList(:) type(ESMF_Field) :: expf,farray(7) @@ -538,40 +542,63 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) integer, allocatable :: seeds(:) type(ESMF_VM) :: vm - call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) - call MAPL_Grid_Interior(grid,i1,in,j1,jn) + if (synth%on_tiles) then + + else + call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) + call MAPL_Grid_Interior(grid,i1,in,j1,jn) + end if call ESMF_StateGet(outState,itemcount=itemCount,_RC) allocate(outNameList(itemCount),stat=status) _VERIFY(status) call ESMF_StateGet(outState,itemNameList=outNameList,_RC) - call MAPL_GetPointer(inState,exPtr2,'time',_RC) - exPtr2=synth%tFunc%evaluate_time(Time,_RC) + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'time',_RC) + exPtr1=synth%tFunc%evaluate_time(Time,_RC) + else + call MAPL_GetPointer(inState,exPtr2,'time',_RC) + exPtr2=synth%tFunc%evaluate_time(Time,_RC) + end if - call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) - do j = 1,ldims(2) - do i=1,ldims(1) - exPtr2(i,j)=i1+i-1 + if (synth%on_tiles) then + + else + call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) + do j = 1,ldims(2) + do i=1,ldims(1) + exPtr2(i,j)=i1+i-1 + enddo enddo - enddo - call MAPL_GetPointer(inState,exPtr2,'j_index',_RC) - do i = 1,ldims(1) - do j=1,ldims(2) - exPtr2(i,j)=j1+j-1 + call MAPL_GetPointer(inState,exPtr2,'j_index',_RC) + do i = 1,ldims(1) + do j=1,ldims(2) + exPtr2(i,j)=j1+j-1 + enddo enddo - enddo + end if - call MAPL_GetPointer(inState,exPtr2,'doy',_RC) - exPtr2 = compute_doy(time,_RC) + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'doy',_RC) + exPtr1 = compute_doy(time,_RC) + else + call MAPL_GetPointer(inState,exPtr2,'doy',_RC) + exPtr2 = compute_doy(time,_RC) + end if - call MAPL_GetPointer(inState,exPtr2,'rand',_RC) call random_seed(size=seed_size) allocate(seeds(seed_size)) call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMGet(vm,localPet=mypet,_RC) seeds = mypet call random_seed(put=seeds) - call random_number(exPtr2) + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'rand',_RC) + call random_number(exPtr1) + else + call MAPL_GetPointer(inState,exPtr2,'rand',_RC) + call random_number(exPtr2) + end if call ESMF_StateGet(inState,'time',farray(1),_RC) call ESMF_StateGet(inState,'lons',farray(2),_RC) From 9913f258d2056f000f48dc468896017f9cff328b Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 18 Jul 2023 11:20:11 -0400 Subject: [PATCH 70/93] introduce portable version of vendor sleep function and use in ExtDataDriver.x --- Tests/ExtDataRoot_GridComp.F90 | 13 ++++++++++ shared/CMakeLists.txt | 1 + shared/MAPL_Sleep.F90 | 44 ++++++++++++++++++++++++++++++++++ shared/MaplShared.F90 | 1 + 4 files changed, 59 insertions(+) create mode 100644 shared/MAPL_Sleep.F90 diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 5800b0007045..d2ca8a7b8f75 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -8,6 +8,7 @@ MODULE ExtDataUtRoot_GridCompMod use ESMF use MAPL + use MAPLShared use VarspecDescriptionMod use VarspecDescriptionVectorMod use netcdf @@ -38,6 +39,7 @@ MODULE ExtDataUtRoot_GridCompMod type(StringStringMap) :: fillDefs character(len=ESMF_MAXSTR) :: runMode type(timeVar) :: tFunc + integer :: delay end type SyntheticFieldSupport type :: SyntheticFieldSupportWrapper @@ -153,6 +155,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(SyntheticFieldSupportWrapper) :: synthWrap type(SyntheticFieldSupport), pointer :: synth => null() character(len=ESMF_MaxStr) :: key, keyVal + logical :: isPresent call ESMF_GridCompGet( GC, name=comp_name, config=CF, _RC ) @@ -161,6 +164,13 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) synth => synthWrap%ptr call ESMF_ClockGet(Clock,currTime=currTime,_RC) + call ESMF_ConfigFindLabel(cf,label='delay:',isPresent=isPresent,_RC) + if (isPresent) then + call ESMF_ConfigGetAttribute(cf,label='delay:',value=synth%delay,_RC) + else + synth%delay = -1 + end if + call ESMF_ConfigGetDim(cf,nrows,ncolumn,label="FILL_DEF::",rc=status) if (status==ESMF_SUCCESS) then call ESMF_ConfigFindLabel(cf,label="FILL_DEF::",_RC) @@ -231,6 +241,9 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) synth => synthWrap%ptr + if (synth%delay > -1) then + call MAPL_Sleep(synth%delay) + end if call ESMF_GridCompGet(GC,grid=grid,_RC) call MAPL_GetPointer(internal,ptrR4,'lons',_RC) call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 620e1553e64a..46389b996a12 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -28,6 +28,7 @@ set (srcs MAPL_DateTime_Parsing.F90 DownBit.F90 ShaveMantissa.c + MAPL_Sleep.F90 # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 diff --git a/shared/MAPL_Sleep.F90 b/shared/MAPL_Sleep.F90 new file mode 100644 index 000000000000..7c36412c9d6f --- /dev/null +++ b/shared/MAPL_Sleep.F90 @@ -0,0 +1,44 @@ +module MAPL_SleepMod + +implicit none +private + +public MAPL_Sleep + +contains + +! wait time in milliseconds +subroutine MAPL_Sleep(wait_time) +integer, intent(in) :: wait_time + +integer :: t(8) + +integer :: current_time, previous_time, start_of_day +integer :: total_accumulation, temp_accumulation, previous_days_accumulated + +call date_and_time(values=t) + +current_time = (t(5)*3600+t(6)*60+t(7))*1000+t(8) +start_of_day = current_time +previous_time = 0 +previous_days_accumulated = 0 +total_accumulation = 0 + +do + + call date_and_time(values=t) + current_time = (t(5)*3600+t(6)*60+t(7))*1000+t(8) + temp_accumulation = current_time - start_of_day + if (current_time < previous_time) then + start_of_day = 0 + previous_days_accumulated = previous_days_accumulated + previous_time + temp_accumulation = current_time - start_of_day + end if + total_accumulation = temp_accumulation + previous_days_accumulated + previous_time = temp_accumulation + if ( total_accumulation > wait_time ) exit + +enddo + +end subroutine +end module MAPL_SleepMod diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index 404e987803a1..859c3e5392c4 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -21,5 +21,6 @@ module MaplShared use mapl_CommGroupDescriptionMod use mapl_AbstractCommSplitterMod use mapl_DownbitMod + use mapl_sleepMod end module MaplShared From c0332f6c33afd33465a1f388418312d90f22ddc4 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 18 Jul 2023 11:22:48 -0400 Subject: [PATCH 71/93] update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index f5c2fc5d8a81..7b892dd0d8e8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Add ability to introduce a time-step delay in ExtDataDriver.x to simulate the timestep latency of a real model +- Added a MAPL\_Sleep function, equivalent to some vendor supplied but non-standard sleep function - sampling IODA file with trajectory sampler (step-1): make it run - Convert ExtData to use ESMF HConfig for YAML parsing rather than YaFYAML - Set required ESMF version to 8.5.0 From fde3a82f89fb8d130ff052c88cb34f9b2cdd8af7 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 18 Jul 2023 11:43:08 -0400 Subject: [PATCH 72/93] change style --- Tests/ExtDataRoot_GridComp.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index d2ca8a7b8f75..0dce67784972 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -164,11 +164,10 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) synth => synthWrap%ptr call ESMF_ClockGet(Clock,currTime=currTime,_RC) + synth%delay = -1 call ESMF_ConfigFindLabel(cf,label='delay:',isPresent=isPresent,_RC) if (isPresent) then call ESMF_ConfigGetAttribute(cf,label='delay:',value=synth%delay,_RC) - else - synth%delay = -1 end if call ESMF_ConfigGetDim(cf,nrows,ncolumn,label="FILL_DEF::",rc=status) From 0409c7002f1a57d02b82f88c72da35d436ced2e4 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Tue, 18 Jul 2023 11:44:24 -0400 Subject: [PATCH 73/93] Update Tests/ExtDataRoot_GridComp.F90 Co-authored-by: Tom Clune --- Tests/ExtDataRoot_GridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 0dce67784972..be0fcd822a5b 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -39,7 +39,7 @@ MODULE ExtDataUtRoot_GridCompMod type(StringStringMap) :: fillDefs character(len=ESMF_MAXSTR) :: runMode type(timeVar) :: tFunc - integer :: delay + integer :: delay ! in milliseconds end type SyntheticFieldSupport type :: SyntheticFieldSupportWrapper From b9198a635b4f1a99b99cec88a9c999fe6998e46f Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 18 Jul 2023 13:39:43 -0400 Subject: [PATCH 74/93] redo sleep to use system_clock --- Tests/ExtDataRoot_GridComp.F90 | 6 ++--- shared/MAPL_Sleep.F90 | 45 ++++++++++++---------------------- 2 files changed, 19 insertions(+), 32 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index be0fcd822a5b..c3f468468ff2 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -39,7 +39,7 @@ MODULE ExtDataUtRoot_GridCompMod type(StringStringMap) :: fillDefs character(len=ESMF_MAXSTR) :: runMode type(timeVar) :: tFunc - integer :: delay ! in milliseconds + real :: delay ! in seconds end type SyntheticFieldSupport type :: SyntheticFieldSupportWrapper @@ -164,7 +164,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) synth => synthWrap%ptr call ESMF_ClockGet(Clock,currTime=currTime,_RC) - synth%delay = -1 + synth%delay = -1.0 call ESMF_ConfigFindLabel(cf,label='delay:',isPresent=isPresent,_RC) if (isPresent) then call ESMF_ConfigGetAttribute(cf,label='delay:',value=synth%delay,_RC) @@ -240,7 +240,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) synth => synthWrap%ptr - if (synth%delay > -1) then + if (synth%delay > -1.0) then call MAPL_Sleep(synth%delay) end if call ESMF_GridCompGet(GC,grid=grid,_RC) diff --git a/shared/MAPL_Sleep.F90 b/shared/MAPL_Sleep.F90 index 7c36412c9d6f..ca77c8412a72 100644 --- a/shared/MAPL_Sleep.F90 +++ b/shared/MAPL_Sleep.F90 @@ -1,5 +1,6 @@ module MAPL_SleepMod +use, intrinsic :: iso_fortran_env, only: REAL64,INT64 implicit none private @@ -7,36 +8,22 @@ module MAPL_SleepMod contains -! wait time in milliseconds +! wait time in seconds subroutine MAPL_Sleep(wait_time) -integer, intent(in) :: wait_time - -integer :: t(8) - -integer :: current_time, previous_time, start_of_day -integer :: total_accumulation, temp_accumulation, previous_days_accumulated - -call date_and_time(values=t) - -current_time = (t(5)*3600+t(6)*60+t(7))*1000+t(8) -start_of_day = current_time -previous_time = 0 -previous_days_accumulated = 0 -total_accumulation = 0 - -do - - call date_and_time(values=t) - current_time = (t(5)*3600+t(6)*60+t(7))*1000+t(8) - temp_accumulation = current_time - start_of_day - if (current_time < previous_time) then - start_of_day = 0 - previous_days_accumulated = previous_days_accumulated + previous_time - temp_accumulation = current_time - start_of_day - end if - total_accumulation = temp_accumulation + previous_days_accumulated - previous_time = temp_accumulation - if ( total_accumulation > wait_time ) exit +real, intent(in) :: wait_time + +integer(kind=INT64) :: s1,s2,count_max,count_rate,delta +real(kind=REAL64) :: seconds_elapsed + +call system_clock(count=s1,count_rate=count_rate,count_max=count_max) + +do + + call system_clock(count=s2) + delta = s2-s1 + if (delta < 0) delta= s2 + (count_max - mod(s1,count_max)) + seconds_elapsed = dble(delta)/dble(count_rate) + if (seconds_elapsed > wait_time) exit enddo From 815ff864b597bd3b1e92c32d7ebe193713b1758a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 18 Jul 2023 14:30:24 -0400 Subject: [PATCH 75/93] inquire only on root --- gridcomps/Cap/MAPL_Cap.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 4e0783e8f684..dbb2640df122 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -271,6 +271,7 @@ subroutine run_model(this, comm, unusable, rc) integer, optional, intent(out) ::rc integer(kind=INT64) :: start_tick, stop_tick, tick_rate + integer :: rank, ierror integer :: status class(Logger), pointer :: lgr logical :: file_exists @@ -279,8 +280,15 @@ subroutine run_model(this, comm, unusable, rc) call start_timer() - ! Look for a file called "ESMF.rc" - inquire(file='ESMF.rc', exist=file_exists) + ! Look for a file called "ESMF.rc" but we want to do this on root and then + ! broadcast the result to the other ranks + + call MPI_COMM_RANK(comm, rank, ierror) + + if (rank == 0) then + inquire(file='ESMF.rc', exist=file_exists) + end if + call MPI_BCAST(file_exists, 1, MPI_LOGICAL, 0, comm, ierror) ! If the file exists, we pass it into ESMF_Initialize, else, we ! use the one from the command line arguments From ba68621e41868130c461694f429817bea9475abc Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 18 Jul 2023 14:58:16 -0400 Subject: [PATCH 76/93] hack until esmf supports user_index on tile fieldcreate --- base/Base/Base_Base.F90 | 7 -- base/Base/Base_Base_implementation.F90 | 57 +-------------- base/MAPL_NewArthParser.F90 | 3 +- geom/FieldPointerUtilities.F90 | 97 ++++++++++++++++++++++++-- 4 files changed, 96 insertions(+), 68 deletions(-) diff --git a/base/Base/Base_Base.F90 b/base/Base/Base_Base.F90 index 4a134533fb40..ebc4b03667fd 100644 --- a/base/Base/Base_Base.F90 +++ b/base/Base/Base_Base.F90 @@ -58,7 +58,6 @@ module MAPL_Base public MAPL_StateAdd public MAPL_FieldBundleAdd public MAPL_FieldBundleGet - public MAPL_FieldDestroy public MAPL_FieldBundleDestroy public MAPL_GetHorzIJIndex public MAPL_GetGlobalHorzIJIndex @@ -642,12 +641,6 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== - module subroutine MAPL_FieldDestroy(Field,RC) - use ESMF, only: ESMF_Field - type(ESMF_Field), intent(INOUT) :: Field - integer, optional, intent(OUT ) :: RC - end subroutine MAPL_FieldDestroy - module subroutine MAPL_FieldBundleDestroy(Bundle,RC) use ESMF, only: ESMF_FieldBundle type(ESMF_FieldBundle), intent(INOUT) :: Bundle diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 4d7631de6c18..1f8d731afed0 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -24,6 +24,7 @@ ! !USES: ! use ESMF + use MAPL_Geom use MAPL_Constants use MAPL_RangeMod use MAPL_SphericalGeometry @@ -2644,60 +2645,6 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== - module subroutine MAPL_FieldDestroy(Field,RC) - type(ESMF_Field), intent(INOUT) :: Field - integer, optional, intent(OUT ) :: RC - - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_FieldDestroy" - integer :: STATUS - - real(kind=ESMF_KIND_R4), pointer :: VAR_1D(:), VAR_2D(:,:), VAR_3D(:,:,:) - real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:) - integer :: rank - type(ESMF_TypeKind_Flag) :: tk - - call ESMF_FieldGet(Field,typekind=tk,dimCount=rank,rc=status) - _VERIFY(STATUS) - if (tk == ESMF_TYPEKIND_R4 .and. rank == 1) then - call ESMF_FieldGet(Field,0,VAR_1d,rc=status) - _VERIFY(STATUS) - deallocate(Var_1d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 1) then - call ESMF_FieldGet(Field,0,VR8_1d,rc=status) - _VERIFY(STATUS) - deallocate(VR8_1d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R4 .and. rank == 2) then - call ESMF_FieldGet(Field,0,VAR_2d,rc=status) - _VERIFY(STATUS) - deallocate(Var_2d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 2) then - call ESMF_FieldGet(Field,0,VR8_2d,rc=status) - _VERIFY(STATUS) - deallocate(VR8_2d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R4 .and. rank == 3) then - call ESMF_FieldGet(Field,0,VAR_3D,rc=status) - _VERIFY(STATUS) - deallocate(Var_3d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 3) then - call ESMF_FieldGet(Field,0,VR8_3D,rc=status) - _VERIFY(STATUS) - deallocate(VR8_3d,stat=status) - _VERIFY(STATUS) - else - _FAIL( 'unsupported typekind+rank') - end if - call ESMF_FieldDestroy(Field,rc=status) - _VERIFY(STATUS) - - _RETURN(ESMF_SUCCESS) - - end subroutine MAPL_FieldDestroy - module subroutine MAPL_FieldBundleDestroy(Bundle,RC) type(ESMF_FieldBundle), intent(INOUT) :: Bundle integer, optional, intent(OUT ) :: RC @@ -2720,7 +2667,7 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) do I = 1, FIELDCOUNT call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) _VERIFY(STATUS) - call MAPL_FieldDestroy(FIELD, RC=status) + call FieldDestroy(FIELD, RC=status) _VERIFY(STATUS) end do end if diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index a96787cf15df..885b3869ce15 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -132,7 +132,8 @@ subroutine bytecode_dealloc(comp,rc) integer :: status do i=1,comp%StackSize - call ESMF_FieldDestroy(comp%stack(i),noGarbage=.true.,_RC) + !call ESMF_FieldDestroy(comp%stack(i),noGarbage=.true.,_RC) + call FieldDestroy(comp%stack(i),_RC) end do deallocate(comp%stack) deallocate(comp%ByteCode) diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 5cc056cc5720..059df9229556 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -19,6 +19,7 @@ module MAPL_FieldPointerUtilities public :: FieldsAreBroadcastConformable public :: FieldsAreSameTypeKind public :: FieldCopy + public :: FieldDestroy public :: FieldCopyBroadcast interface GetFieldsUndef @@ -74,6 +75,10 @@ module MAPL_FieldPointerUtilities interface FieldCopyBroadcast procedure copy_broadcast end interface FieldCopyBroadcast + + interface FieldDestroy + procedure destroy + end interface contains @@ -373,21 +378,56 @@ subroutine clone(x, y, rc) character(len=ESMF_MAXSTR) :: name integer :: status integer :: field_rank, grid_rank,ungrid_size + type(ESMF_Index_Flag) :: index_flag + real(kind=ESMF_KIND_R4), pointer :: VR4_1D(:), VR4_2D(:,:), VR4_3D(:,:,:), VR4_4D(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:), VR8_4D(:,:,:,:) + integer, allocatable :: lc(:) call ESMF_FieldGet(x,grid=grid,rank=field_rank,_RC) - call ESMF_GridGet(grid,dimCount=grid_rank,_RC) + lc = get_local_element_count(x,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank,indexFlag=index_flag,_RC) ungrid_size = field_rank-grid_rank allocate(gridToFieldMap(grid_rank)) allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) call ESMF_FieldGet(x, typekind=tk, name = name, & staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) name = trim(name) // CLONE_TAG - y = ESMF_FieldCreate(grid, typekind=tk, staggerloc=staggerloc, & - gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & - ungriddedUBound=ungriddedUBound, name=name, _RC) + if (index_flag == ESMF_INDEX_USER) then + if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 1) then + allocate(VR4_1d(lc(1)),_STAT) + y = ESMF_FieldCreate(grid,VR4_1d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 1) then + allocate(VR8_1d(lc(1)),_STAT) + y = ESMF_FieldCreate(grid,VR8_1d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 2) then + allocate(VR4_2d(lc(1),lc(2)),_STAT) + y = ESMF_FieldCreate(grid,VR4_2d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 2) then + allocate(VR8_2d(lc(1),lc(2)),_STAT) + y = ESMF_FieldCreate(grid,VR8_2d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 3) then + allocate(VR4_3d(lc(1),lc(2),lc(3)),_STAT) + y = ESMF_FieldCreate(grid,VR4_3d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 3) then + allocate(VR8_3d(lc(1),lc(2),lc(3)),_STAT) + y = ESMF_FieldCreate(grid,VR8_3d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 4) then + allocate(VR4_4d(lc(1),lc(2),lc(3),lc(4)),_STAT) + y = ESMF_FieldCreate(grid,VR4_4d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 4) then + allocate(VR8_4d(lc(1),lc(2),lc(3),lc(4)),_STAT) + y = ESMF_FieldCreate(grid,VR8_4d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else + _FAIL( 'unsupported typekind+field_rank') + end if + else + y = ESMF_FieldCreate(grid, tk, staggerloc=staggerloc, & + gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & + ungriddedUBound=ungriddedUBound, name=name, _RC) + end if _RETURN(_SUCCESS) end subroutine clone @@ -859,4 +899,51 @@ subroutine GetFieldsUndef_r8(fields,undef_values,rc) _RETURN(_SUCCESS) end subroutine GetFieldsUndef_r8 +subroutine Destroy(Field,RC) + type(ESMF_Field), intent(INOUT) :: Field + integer, optional, intent(OUT ) :: RC + + integer :: STATUS + + real(kind=ESMF_KIND_R4), pointer :: VR4_1D(:), VR4_2D(:,:), VR4_3D(:,:,:), VR4_4D(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:), VR8_4D(:,:,:,:) + integer :: rank + type(ESMF_TypeKind_Flag) :: tk + logical :: esmf_allocated + + call ESMF_FieldGet(Field,typekind=tk,dimCount=rank,isESMFAllocated=esmf_allocated,_RC) + if (.not. esmf_allocated) then + if (tk == ESMF_TYPEKIND_R4 .and. rank == 1) then + call ESMF_FieldGet(Field,0,VR4_1d,_RC) + deallocate(VR4_1d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 1) then + call ESMF_FieldGet(Field,0,VR8_1d,_RC) + deallocate(VR8_1d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 2) then + call ESMF_FieldGet(Field,0,VR4_2d,_RC) + deallocate(VR4_2d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 2) then + call ESMF_FieldGet(Field,0,VR8_2d,_RC) + deallocate(VR8_2d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 3) then + call ESMF_FieldGet(Field,0,VR4_3D,_RC) + deallocate(VR4_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 3) then + call ESMF_FieldGet(Field,0,VR8_3D,_RC) + deallocate(VR8_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 4) then + call ESMF_FieldGet(Field,0,VR4_4D,_RC) + deallocate(VR4_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 4) then + call ESMF_FieldGet(Field,0,VR8_4D,_RC) + deallocate(VR8_3d,_STAT) + else + _FAIL( 'unsupported typekind+rank') + end if + end if + call ESMF_FieldDestroy(Field,noGarbage = .true., rc=status) + _VERIFY(STATUS) + _RETURN(ESMF_SUCCESS) + + end subroutine Destroy end module From 34f08a924e11476430f703d9348ab2fd854bcca1 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 19 Jul 2023 11:10:55 -0400 Subject: [PATCH 77/93] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7b892dd0d8e8..ef3a3e2eb4cc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added ability to run ExtDataDriver.x on a MAPL "tile" grid - Add ability to introduce a time-step delay in ExtDataDriver.x to simulate the timestep latency of a real model - Added a MAPL\_Sleep function, equivalent to some vendor supplied but non-standard sleep function - sampling IODA file with trajectory sampler (step-1): make it run From 0994ed2fd0db8a7087e42ce1be89c6f30d353467 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 19 Jul 2023 11:16:04 -0400 Subject: [PATCH 78/93] Fixes #2244. Add print of regrid method to history init --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 1 + 2 files changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 587833d812dd..53210a918774 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added print of regrid method during History initialization - Add ability to introduce a time-step delay in ExtDataDriver.x to simulate the timestep latency of a real model - Added a MAPL\_Sleep function, equivalent to some vendor supplied but non-standard sleep function - sampling IODA file with trajectory sampler (step-1): make it run diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 5704080a8b81..a01c4bc22200 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2440,6 +2440,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) print *, ' End_Date: ', list(n)%end_date print *, ' End_Time: ', list(n)%end_time endif + print *, ' Regrid Mthd: ', regrid_method_int_to_string(list(n)%regrid_method) block integer :: im_world, jm_world,dims(3) From 705edd4a8dea24dfbd6cf05245240b890154b844 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Thu, 20 Jul 2023 09:28:37 -0400 Subject: [PATCH 79/93] Update Tests/ExtDataRoot_GridComp.F90 Co-authored-by: Tom Clune --- Tests/ExtDataRoot_GridComp.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 718c12fab4df..08aa2c0d7ee0 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -573,9 +573,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) exPtr2=synth%tFunc%evaluate_time(Time,_RC) end if - if (synth%on_tiles) then - - else + if (.not. synth%on_tiles) then call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) do j = 1,ldims(2) do i=1,ldims(1) From e7514b3661b58b0ef41ba04f7d3c01bffad58c89 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 20 Jul 2023 10:26:51 -0400 Subject: [PATCH 80/93] change back to MAPL_FieldDestroy from FieldDestroy as external libraries use MAPL_FieldDestroy --- base/Base/Base_Base_implementation.F90 | 2 +- base/MAPL_NewArthParser.F90 | 3 +-- geom/FieldPointerUtilities.F90 | 4 ++-- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 1f8d731afed0..627cfa3c2ef4 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2667,7 +2667,7 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) do I = 1, FIELDCOUNT call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) _VERIFY(STATUS) - call FieldDestroy(FIELD, RC=status) + call MAPL_FieldDestroy(FIELD, RC=status) _VERIFY(STATUS) end do end if diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index 885b3869ce15..72f62579a996 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -132,8 +132,7 @@ subroutine bytecode_dealloc(comp,rc) integer :: status do i=1,comp%StackSize - !call ESMF_FieldDestroy(comp%stack(i),noGarbage=.true.,_RC) - call FieldDestroy(comp%stack(i),_RC) + call MAPL_FieldDestroy(comp%stack(i),_RC) end do deallocate(comp%stack) deallocate(comp%ByteCode) diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 059df9229556..aa6cdddd3a11 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -19,7 +19,7 @@ module MAPL_FieldPointerUtilities public :: FieldsAreBroadcastConformable public :: FieldsAreSameTypeKind public :: FieldCopy - public :: FieldDestroy + public :: MAPL_FieldDestroy public :: FieldCopyBroadcast interface GetFieldsUndef @@ -76,7 +76,7 @@ module MAPL_FieldPointerUtilities procedure copy_broadcast end interface FieldCopyBroadcast - interface FieldDestroy + interface MAPL_FieldDestroy procedure destroy end interface contains From 67f2520d46d1e433d40fad94bb7fb8e4c67401d6 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 20 Jul 2023 13:33:58 -0400 Subject: [PATCH 81/93] Fix odd if --- Tests/ExtDataRoot_GridComp.F90 | 38 ++++++++++++++++------------------ 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 08aa2c0d7ee0..6bbe85200b62 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -1,10 +1,10 @@ - + !------------------------------------------------------------------------- ! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! !------------------------------------------------------------------------- ! #include "MAPL_Generic.h" - + MODULE ExtDataUtRoot_GridCompMod use ESMF use MAPL @@ -152,7 +152,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_State), intent(inout) :: EXPORT ! Export State integer, intent(out) :: rc ! Error return code: - type(ESMF_Config) :: CF ! Universal Config + type(ESMF_Config) :: CF ! Universal Config integer :: status character(len=ESMF_MAXSTR) :: comp_name @@ -290,7 +290,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_GetPointer(internal,ptrR4,'lats',_RC) call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=ptrR8, _RC) + farrayPtr=ptrR8, _RC) ptrR4=ptrR8 end if @@ -298,17 +298,17 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) case(RunModeGenerateExports) - call FillState(internal,export,currTime,grid,synth,_RC) + call FillState(internal,export,currTime,grid,synth,_RC) case(RunModeGenerateImports) - call FillState(internal,import,currTime,grid,synth,_RC) + call FillState(internal,import,currTime,grid,synth,_RC) case(runModecompareImports) call FillState(internal,export,currTime,grid,synth,_RC) - call CompareState(import,export,0.001,_RC) + call CompareState(import,export,0.001,_RC) - case(runModeFillImport) + case(runModeFillImport) ! Nothing to do, we are just letting ExtData run case(runModeFillExportFromImport) @@ -430,9 +430,9 @@ function evaluate_time(this,currTime,rc) result(dt) call ESMF_TimeIntervalSet(yearInterval,yy=yint,_RC) currTime = currTime+yearInterval end if - periodic_time = this%set_time_for_date(currTime,_RC) + periodic_time = this%set_time_for_date(currTime,_RC) if (this%have_offset) then - timeInterval = periodic_time + this%update_offset - this%refTime + timeInterval = periodic_time + this%update_offset - this%refTime else timeInterval = periodic_time - this%refTime end if @@ -469,7 +469,7 @@ function set_time_for_date(this,input_time,rc) result(returned_time) returned_time = input_time else if (new_time < input_time) then returned_time = new_time - else if (new_time > input_time) then + else if (new_time > input_time) then call ESMF_TimeSet(new_time,yy=year,mm=month,dd=day-1,h=hour,m=minute,s=second,_RC) returned_time = new_time end if @@ -529,7 +529,7 @@ subroutine CopyState(inState,outState,rc) EXptr3=IMptr3 end if end do - deallocate(inNameList,outNameList) + deallocate(inNameList,outNameList) _RETURN(ESMF_SUCCESS) end subroutine CopyState @@ -554,9 +554,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) integer, allocatable :: seeds(:) type(ESMF_VM) :: vm - if (synth%on_tiles) then - - else + if (.not. synth%on_tiles) then call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) call MAPL_Grid_Interior(grid,i1,in,j1,jn) end if @@ -649,7 +647,7 @@ subroutine CompareState(State1,State2,tol,rc) logical, allocatable :: foundDiff(:) type(ESMF_Field) :: Field1,Field2 logical :: all_undef1, all_undef2 - + call ESMF_StateGet(State1,itemcount=itemCount,_RC) allocate(NameList(itemCount),stat=status) _VERIFY(status) @@ -687,11 +685,11 @@ subroutine CompareState(State1,State2,tol,rc) foundDiff(i) = .true. end if end if - if (foundDiff(i)) then + if (foundDiff(i)) then _FAIL('found difference when compare state') end if enddo - + _RETURN(ESMF_SUCCESS) end subroutine CompareState @@ -699,9 +697,9 @@ end subroutine CompareState subroutine ForceAllocation(state,rc) type(ESMF_State), intent(inout) :: state integer, optional, intent(out) :: rc - + integer :: status - + real, pointer :: ptr3d(:,:,:) real, pointer :: ptr2d(:,:) integer :: ii From 3a82e840ce1a6dc16a9bf9370aa5f0c42ae18d5e Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 25 Jul 2023 14:24:23 -0400 Subject: [PATCH 82/93] extdata on tiles, yay! --- base/NCIO.F90 | 2 +- gridcomps/ExtData2G/ExtDataGridCompNG.F90 | 27 +++-- gridcomps/ExtData2G/ExtData_IOBundleMod.F90 | 31 +++-- griddedio/CMakeLists.txt | 1 + griddedio/DataCollection.F90 | 9 +- griddedio/TileIO.F90 | 120 ++++++++++++++++++++ 6 files changed, 171 insertions(+), 19 deletions(-) create mode 100644 griddedio/TileIO.F90 diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 873ebf6ebf34..ddf0a1b26f0d 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -40,7 +40,7 @@ module NCIOMod public MAPL_VarRead public MAPL_VarWrite public get_fname_by_face - public MAPL_TileMaskGet + !public MAPL_TileMaskGet public MAPL_NCIOGetFileType public MAPL_VarReadNCPar public MAPL_VarWriteNCPar diff --git a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 index 3272e8a1092c..ced440561449 100644 --- a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 +++ b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 @@ -61,6 +61,7 @@ MODULE MAPL_ExtDataGridComp2G use pflogger, only: logging, Logger use MAPL_ExtDataLogger use MAPL_ExtDataConstants + use gFTL_StringIntegerMap IMPLICIT NONE PRIVATE @@ -1346,7 +1347,7 @@ subroutine MAPL_ExtDataCreateCFIO(IOBundles, rc) bundle_iter = IOBundles%begin() do while (bundle_iter /= IOBundles%end()) io_bundle => bundle_iter%get() - call io_bundle%make_cfio(_RC) + call io_bundle%make_io(_RC) call bundle_iter%next() enddo @@ -1386,8 +1387,11 @@ subroutine MAPL_ExtDataPrefetch(IOBundles,rc) do n = 1, nfiles io_bundle => IOBundles%at(n) - call io_bundle%cfio%request_data_from_file(io_bundle%file_name,io_bundle%time_index,rc=status) - _VERIFY(status) + if (io_bundle%on_tiles) then + call io_bundle%tile_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) + else + call io_bundle%grid_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) + end if enddo _RETURN(ESMF_SUCCESS) @@ -1406,8 +1410,11 @@ subroutine MAPL_ExtDataReadPrefetch(IOBundles,rc) nfiles = IOBundles%size() do n=1, nfiles io_bundle => IOBundles%at(n) - call io_bundle%cfio%process_data_from_file(rc=status) - _VERIFY(status) + if (io_bundle%on_tiles) then + call io_bundle%tile_io%process_data_from_file(_RC) + else + call io_bundle%grid_io%process_data_from_file(_RC) + end if enddo _RETURN(ESMF_SUCCESS) @@ -1453,13 +1460,19 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,rc) logical :: update character(len=ESMF_MAXPATHLEN) :: current_file integer :: time_index + type(StringIntegerMap), pointer :: dimensions + integer, pointer :: tile_size + logical :: on_tiles + dimensions => item%file_metadata%get_dimensions() + tile_size => dimensions%at("num_tiles") + on_tiles = associated(tile_size) call item%modelGridFields%comp1%get_parameters('L',update=update,file=current_file,time_index=time_index) if (update) then if (trim(current_file)/=file_not_found) then call itemsL%push_back(item%fileVars) io_bundle = ExtDataNG_IOBundle(MAPL_ExtDataLeft, entry_num, current_file, time_index, item%trans, item%fracval, item%file_template, & - item%pfioCollection_id,item%iclient_collection_id,itemsL,rc=status) + item%pfioCollection_id,item%iclient_collection_id,itemsL,on_tiles,rc=status) _VERIFY(status) call IOBundles%push_back(io_bundle) call extdata_lgr%info('%a updated L bracket with: %a at time index %i3 ',item%name, current_file, time_index) @@ -1470,7 +1483,7 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,rc) if (trim(current_file)/=file_not_found) then call itemsR%push_back(item%fileVars) io_bundle = ExtDataNG_IOBundle(MAPL_ExtDataRight, entry_num, current_file, time_index, item%trans, item%fracval, item%file_template, & - item%pfioCollection_id,item%iclient_collection_id,itemsR,rc=status) + item%pfioCollection_id,item%iclient_collection_id,itemsR,on_tiles,rc=status) _VERIFY(status) call IOBundles%push_back(io_bundle) call extdata_lgr%info('%a updated R bracket with: %a at time index %i3 ',item%name,current_file, time_index) diff --git a/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 b/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 index 1e116ee47a8d..eda391c11d01 100644 --- a/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 +++ b/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 @@ -10,6 +10,7 @@ module MAPL_ExtDataNG_IOBundleMod use ESMF use MAPL_BaseMod use MAPL_GriddedIOMod + use MAPL_TileIOMod use MAPL_ExceptionHandling use MAPL_GriddedIOItemMod use MAPL_GriddedIOItemVectorMod @@ -17,7 +18,8 @@ module MAPL_ExtDataNG_IOBundleMod public :: ExtDataNG_IOBundle type ExtDataNG_IOBundle - type (MAPL_GriddedIO) :: cfio + type (MAPL_GriddedIO) :: grid_io + type (MAPL_TileIO) :: tile_io type (ESMF_FieldBundle) :: pbundle character(:), allocatable :: template integer :: regrid_method @@ -30,11 +32,12 @@ module MAPL_ExtDataNG_IOBundleMod integer :: metadata_coll_id integer :: server_coll_id type(GriddedIOItemVector) :: items + logical :: on_tiles contains procedure :: clean - procedure :: make_cfio + procedure :: make_io procedure :: assign generic :: assignment(=) => assign end type ExtDataNG_IOBundle @@ -46,7 +49,7 @@ module MAPL_ExtDataNG_IOBundleMod contains - function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index, regrid_method, fraction, template, metadata_coll_id,server_coll_id,items,rc) result(io_bundle) + function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index, regrid_method, fraction, template, metadata_coll_id,server_coll_id,items, on_tiles, rc) result(io_bundle) type (ExtDataNG_IOBundle) :: io_bundle integer, intent(in) :: bracket_side @@ -59,6 +62,7 @@ function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index integer, intent(in) :: metadata_coll_id integer, intent(in) :: server_coll_id type(GriddedIOItemVector) :: items + logical, intent(in) :: on_tiles integer, optional, intent(out) :: rc io_bundle%bracket_side = bracket_side @@ -72,6 +76,7 @@ function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index io_bundle%metadata_coll_id=metadata_coll_id io_bundle%server_coll_id=server_coll_id io_bundle%items=items + io_bundle%on_tiles = on_tiles _RETURN(ESMF_SUCCESS) end function new_ExtDataNG_IOBundle @@ -90,18 +95,22 @@ subroutine clean(this, rc) end subroutine clean - subroutine make_cfio(this, rc) + subroutine make_io(this, rc) class (ExtDataNG_IOBundle), intent(inout) :: this integer, optional, intent(out) :: rc - this%cfio = MAPL_GriddedIO(output_bundle=this%pbundle,regrid_method=this%regrid_method, & - read_collection_id=this%server_coll_id, & - metadata_collection_id = this%metadata_coll_id, fraction = this%fraction, & - items=this%items) + if (this%on_tiles) then + this%tile_io = MAPL_TileIO(this%pbundle,this%server_coll_id) + else + this%grid_io = MAPL_GriddedIO(output_bundle=this%pbundle,regrid_method=this%regrid_method, & + read_collection_id=this%server_coll_id, & + metadata_collection_id = this%metadata_coll_id, fraction = this%fraction, & + items=this%items) + end if _RETURN(ESMF_SUCCESS) - end subroutine make_cfio + end subroutine make_io subroutine assign(to,from) class(ExtDataNG_IOBundle), intent(out) :: to @@ -119,7 +128,9 @@ subroutine assign(to,from) to%server_coll_id=from%server_coll_id to%items=from%items to%pbundle=from%pbundle - to%CFIO=from%CFIO + to%grid_io=from%grid_io + to%tile_io=from%tile_io + to%on_tiles=from%on_tiles end subroutine assign diff --git a/griddedio/CMakeLists.txt b/griddedio/CMakeLists.txt index a34c6fdab1c0..1721226ab822 100644 --- a/griddedio/CMakeLists.txt +++ b/griddedio/CMakeLists.txt @@ -7,6 +7,7 @@ set (srcs GriddedIO.F90 FieldBundleRead.F90 FieldBundleWrite.F90 + TileIO.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.pfio diff --git a/griddedio/DataCollection.F90 b/griddedio/DataCollection.F90 index 9dd092e7ad10..4ea11e38fd5f 100644 --- a/griddedio/DataCollection.F90 +++ b/griddedio/DataCollection.F90 @@ -61,6 +61,9 @@ function find(this, file_name, rc) result(metadata) type (StringIntegerMapIterator) :: iter class (AbstractGridFactory), allocatable :: factory integer :: status + type(StringIntegerMap), pointer :: dimensions + integer, pointer :: tile_size + logical :: skip_grid file_id => this%file_ids%at(file_name) @@ -103,7 +106,11 @@ function find(this, file_name, rc) result(metadata) call this%metadatas%push_back(metadata) deallocate(metadata) metadata => this%metadatas%back() - if (.not. allocated(this%src_grid)) then + dimensions => metadata%get_dimensions() + tile_size => dimensions%at("num_tiles") + skip_grid = associated(tile_size) + + if ( (.not. allocated(this%src_grid)) .and. (.not. skip_grid)) then allocate(factory, source=grid_manager%make_factory(trim(file_name),force_file_coordinates=this%use_file_coords)) this%src_grid = grid_manager%make_grid(factory) end if diff --git a/griddedio/TileIO.F90 b/griddedio/TileIO.F90 new file mode 100644 index 000000000000..85fbaffcbf44 --- /dev/null +++ b/griddedio/TileIO.F90 @@ -0,0 +1,120 @@ +#include "MAPL_Generic.h" + +module MAPL_TileIOMod + use ESMF + use pFIO + use MAPL_BaseMod + use MAPL_ExceptionHandling + use MAPL_CommsMod + use FIleIOSharedMod, only: MAPL_TileMaskGet + + implicit none + + private + + type, public :: MAPL_TileIO + type(ESMF_FieldBundle) :: bundle + integer :: read_collection_id + type(tile_buffer), allocatable :: tile_buffer(:) + contains + procedure :: request_data_from_file + procedure :: process_data_from_file + end type MAPL_TileIO + + type tile_buffer + real, allocatable :: ptr(:) + end type + + interface MAPL_TileIO + module procedure new_MAPL_TileIO + end interface MAPL_TileIO + + contains + + function new_MAPL_TileIO(bundle,read_collection_id) result(TileIO) + type(MAPL_TileIO) :: TileIO + type(ESMF_FieldBundle),intent(in) :: bundle + integer, intent(in) :: read_collection_id + + TileIO%bundle = bundle + TileIO%read_collection_id = read_collection_id + end function + + subroutine request_data_from_file(this,filename,timeindex,rc) + class(MAPL_TileIO), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, intent(in) :: timeindex + integer, intent(out), optional :: rc + + integer :: status + integer :: num_vars,i,rank + type(ArrayReference) :: ref + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Field) :: field + type(ESMF_Grid) :: grid + integer :: counts(3) + integer, allocatable :: local_start(:), global_start(:), global_count(:) + + + call ESMF_FieldBundleGet(this%bundle, fieldCount=num_vars, _RC) + allocate(this%tile_buffer(num_vars)) + allocate(names(num_vars)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=names, _RC) + do i=1,num_vars + call ESMF_FieldBundleGet(this%bundle,names(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,grid=grid,_RC) + call MAPL_GridGet(grid,globalCellCountPerDim=counts,_RC) + if (rank==1) then + allocate(local_start(2),global_start(2),global_count(2)) + local_start = [1,timeindex] + global_start = [1,timeindex] + global_count = [counts(1),1] + if (mapl_am_I_root()) then + allocate(this%tile_buffer(i)%ptr(counts(1)),_STAT) + else + allocate(this%tile_buffer(i)%ptr((0)),_STAT) + end if + ref = ArrayReference(this%tile_buffer(i)%ptr) + call i_clients%collective_prefetch_data(this%read_collection_id, filename, trim(names(i)), ref, & + start=local_start, global_start=global_start, global_count = global_count) + deallocate(local_start,global_start,global_count) + else + _FAIL("rank >1 tile fields not supported") + end if + end do + + _RETURN(_SUCCESS) + end subroutine + + subroutine process_data_from_file(this,rc) + class(MAPL_TileIO), intent(inout) :: this + integer, intent(out), optional :: rc + + integer :: status + integer :: i,num_vars,rank + type(ESMF_Field) :: field + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Grid) :: grid + integer, pointer :: mask(:) + real, pointer :: ptr1d(:) + + call ESMF_FieldBundleGet(this%bundle, fieldCount=num_vars, _RC) + allocate(names(num_vars)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=names, _RC) + do i=1,num_vars + call ESMF_FieldBundleGet(this%bundle,names(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,grid=grid,_RC) + call MAPL_TileMaskGet(grid,mask,_RC) + if (rank==1) then + call ESMF_FieldGet(field,localDE=0,farrayPtr=ptr1d,_RC) + call ArrayScatter(ptr1d,this%tile_buffer(i)%ptr,grid,mask=mask,_RC) + deallocate(this%tile_buffer(i)%ptr) + else + _FAIL("rank not supported for tile io") + end if + enddo + deallocate(this%tile_buffer) + _RETURN(_SUCCESS) + end subroutine + +end module From 2af409199a8f473bf72048b243e3e3527ef87fdb Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 25 Jul 2023 16:15:28 -0400 Subject: [PATCH 83/93] also do 1D... --- gridcomps/ExtData2G/ExtDataBracket.F90 | 38 +++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/gridcomps/ExtData2G/ExtDataBracket.F90 b/gridcomps/ExtData2G/ExtDataBracket.F90 index f6fd5dc964f9..fd3390d355eb 100644 --- a/gridcomps/ExtData2G/ExtDataBracket.F90 +++ b/gridcomps/ExtData2G/ExtDataBracket.F90 @@ -178,8 +178,11 @@ subroutine interpolate_to_time(this,field,time,rc) type(ESMF_TimeInterval) :: tinv1, tinv2 real :: alpha + real, pointer :: var1d(:) => null() real, pointer :: var2d(:,:) => null() real, pointer :: var3d(:,:,:) => null() + real, pointer :: var1d_left(:) => null() + real, pointer :: var1d_right(:) => null() real, pointer :: var2d_left(:,:) => null() real, pointer :: var2d_right(:,:) => null() real, pointer :: var3d_left(:,:,:) => null() @@ -204,7 +207,40 @@ subroutine interpolate_to_time(this,field,time,rc) tinv2 = this%right_node%time - this%left_node%time alpha = tinv1/tinv2 end if - if (field_rank==2) then + if (field_rank==1) then + + call esmf_fieldget(field,localde=0,farrayptr=var1d,_RC) + if (right_node_set) then + call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var1d_right,_RC) + end if + if (left_node_set) then + call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var1d_left,_RC) + end if + if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then + var1d = var1d_left + else if (right_node_set .and. (time == this%right_node%time)) then + var1d = var1d_right + else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then + where( (var1d_left /= mapl_undef) .and. (var1d_right /= mapl_undef)) + var1d = var1d_left + alpha*(var1d_right-var1d_left) + elsewhere + var1d = mapl_undef + endwhere + else + var1d = mapl_undef + end if + + if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d+this%offset + end if + if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor + end if + if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor+this%offset + end if + + else if (field_rank==2) then call esmf_fieldget(field,localde=0,farrayptr=var2d,_RC) if (right_node_set) then From f7dc7a9964c63cea6566e91b25858f63c29f6d5c Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 26 Jul 2023 09:38:57 -0400 Subject: [PATCH 84/93] fixup for 1d --- gridcomps/ExtData2G/ExtDataBracket.F90 | 135 ++++++------------------- 1 file changed, 29 insertions(+), 106 deletions(-) diff --git a/gridcomps/ExtData2G/ExtDataBracket.F90 b/gridcomps/ExtData2G/ExtDataBracket.F90 index fd3390d355eb..fcbfa3958c6d 100644 --- a/gridcomps/ExtData2G/ExtDataBracket.F90 +++ b/gridcomps/ExtData2G/ExtDataBracket.F90 @@ -8,6 +8,7 @@ module MAPL_ExtDataBracket use MAPL_ExtDataNode use MAPL_ExtDataConstants use MAPL_CommsMod + use MAPL_Geom implicit none private @@ -41,7 +42,7 @@ subroutine reset(this) this%new_file_right=.false. this%new_file_left =.false. end subroutine reset - +! function time_in_bracket(this,time) result(in_bracket) class(ExtDataBracket), intent(in) :: this logical :: in_bracket @@ -179,15 +180,8 @@ subroutine interpolate_to_time(this,field,time,rc) type(ESMF_TimeInterval) :: tinv1, tinv2 real :: alpha real, pointer :: var1d(:) => null() - real, pointer :: var2d(:,:) => null() - real, pointer :: var3d(:,:,:) => null() real, pointer :: var1d_left(:) => null() real, pointer :: var1d_right(:) => null() - real, pointer :: var2d_left(:,:) => null() - real, pointer :: var2d_right(:,:) => null() - real, pointer :: var3d_left(:,:,:) => null() - real, pointer :: var3d_right(:,:,:) => null() - integer :: field_rank integer :: status logical :: right_node_set, left_node_set character(len=ESMF_MAXPATHLEN) :: left_file, right_file @@ -207,106 +201,35 @@ subroutine interpolate_to_time(this,field,time,rc) tinv2 = this%right_node%time - this%left_node%time alpha = tinv1/tinv2 end if - if (field_rank==1) then - - call esmf_fieldget(field,localde=0,farrayptr=var1d,_RC) - if (right_node_set) then - call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var1d_right,_RC) - end if - if (left_node_set) then - call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var1d_left,_RC) - end if - if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then - var1d = var1d_left - else if (right_node_set .and. (time == this%right_node%time)) then - var1d = var1d_right - else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then - where( (var1d_left /= mapl_undef) .and. (var1d_right /= mapl_undef)) - var1d = var1d_left + alpha*(var1d_right-var1d_left) - elsewhere - var1d = mapl_undef - endwhere - else + call assign_fptr(field,var1d,_RC) + if (right_node_set) then + call assign_fptr(this%right_node%field,var1d_right,_RC) + end if + if (left_node_set) then + call assign_fptr(this%left_node%field,var1d_left,_RC) + end if + if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then + var1d = var1d_left + else if (right_node_set .and. (time == this%right_node%time)) then + var1d = var1d_right + else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then + where( (var1d_left /= mapl_undef) .and. (var1d_right /= mapl_undef)) + var1d = var1d_left + alpha*(var1d_right-var1d_left) + elsewhere var1d = mapl_undef - end if - - if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then - where(var1d /= MAPL_UNDEF) var1d=var1d+this%offset - end if - if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then - where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor - end if - if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then - where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor+this%offset - end if - - else if (field_rank==2) then - - call esmf_fieldget(field,localde=0,farrayptr=var2d,_RC) - if (right_node_set) then - call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var2d_right,_RC) - end if - if (left_node_set) then - call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var2d_left,_RC) - end if - if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then - var2d = var2d_left - else if (right_node_set .and. (time == this%right_node%time)) then - var2d = var2d_right - else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then - where( (var2d_left /= mapl_undef) .and. (var2d_right /= mapl_undef)) - var2d = var2d_left + alpha*(var2d_right-var2d_left) - elsewhere - var2d = mapl_undef - endwhere - else - var2d = mapl_undef - end if - - if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d+this%offset - end if - if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d*this%scale_factor - end if - if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d*this%scale_factor+this%offset - end if - - else if (field_rank==3) then - call esmf_fieldget(field,localde=0,farrayptr=var3d,_RC) - if (right_node_set) then - call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var3d_right,_RC) - end if - if (left_node_set) then - call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var3d_left,_RC) - end if - if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation) ) then - var3d = var3d_left - else if ( right_node_set .and. (time == this%right_node%time) ) then - var3d = var3d_right - else if (right_node_set .and. (time == this%right_node%time)) then - var3d = var3d_right - else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) )then - where( (var3d_left /= mapl_undef) .and. (var3d_right /= mapl_undef)) - var3d = var3d_left + alpha*(var3d_right-var3d_left) - elsewhere - var3d = mapl_undef - endwhere - else - var3d = mapl_undef - end if - - if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d+this%offset - end if - if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d*this%scale_factor - end if - if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d*this%scale_factor+this%offset - end if + endwhere + else + var1d = mapl_undef + end if + if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d+this%offset + end if + if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor + end if + if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor+this%offset end if _RETURN(_SUCCESS) From 602081ced6057059f0c702b94977701335fe3281 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 26 Jul 2023 12:24:58 -0400 Subject: [PATCH 85/93] more updates for tiles --- gridcomps/ExtData2G/ExtDataBracket.F90 | 19 ++++--------------- gridcomps/ExtData2G/ExtDataGridCompNG.F90 | 2 +- griddedio/DataCollection.F90 | 2 +- 3 files changed, 6 insertions(+), 17 deletions(-) diff --git a/gridcomps/ExtData2G/ExtDataBracket.F90 b/gridcomps/ExtData2G/ExtDataBracket.F90 index fcbfa3958c6d..9ef4fd590362 100644 --- a/gridcomps/ExtData2G/ExtDataBracket.F90 +++ b/gridcomps/ExtData2G/ExtDataBracket.F90 @@ -193,8 +193,6 @@ subroutine interpolate_to_time(this,field,time,rc) right_node_set = right_file /= file_not_found left_node_set = left_file /= file_not_found - - call ESMF_FieldGet(field,dimCount=field_rank,_RC) alpha = 0.0 if ( (.not.this%disable_interpolation) .and. (.not.this%intermittent_disable) .and. right_node_set .and. left_node_set) then tinv1 = time - this%left_node%time @@ -240,24 +238,15 @@ subroutine swap_node_fields(this,rc) class(ExtDataBracket), intent(inout) :: this integer, optional, intent(out) :: rc integer :: status - integer :: field_rank - real, pointer :: var3d_left(:,:,:),var3d_right(:,:,:) - real, pointer :: var2d_left(:,:),var2d_right(:,:) + real, pointer :: left_ptr(:), right_ptr(:) logical :: left_created, right_created left_created = ESMF_FieldIsCreated(this%left_node%field,_RC) right_created = ESMF_FieldIsCreated(this%right_node%field,_RC) if (left_created .and. right_created) then - call ESMF_FieldGet(this%left_node%field,dimCount=field_rank,_RC) - if (field_rank == 2) then - call ESMF_FieldGet(this%right_node%field,localDE=0,farrayPtr=var2d_right,_RC) - call ESMF_FieldGet(this%left_node%field,localDE=0,farrayPtr=var2d_left,_RC) - var2d_left = var2d_right - else if (field_rank ==3) then - call ESMF_FieldGet(this%right_node%field,localDE=0,farrayPtr=var3d_right,_RC) - call ESMF_FieldGet(this%left_node%field,localDE=0,farrayPtr=var3d_left,_RC) - var3d_left = var3d_right - end if + call assign_fptr(this%left_node%field,left_ptr,_RC) + call assign_fptr(this%right_node%field,right_ptr,_RC) + left_ptr = right_ptr end if _RETURN(_SUCCESS) end subroutine swap_node_fields diff --git a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 index ced440561449..957f6d7cc02a 100644 --- a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 +++ b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 @@ -1465,7 +1465,7 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,rc) logical :: on_tiles dimensions => item%file_metadata%get_dimensions() - tile_size => dimensions%at("num_tiles") + tile_size => dimensions%at("tile_index") on_tiles = associated(tile_size) call item%modelGridFields%comp1%get_parameters('L',update=update,file=current_file,time_index=time_index) if (update) then diff --git a/griddedio/DataCollection.F90 b/griddedio/DataCollection.F90 index 4ea11e38fd5f..c881a4f8bd04 100644 --- a/griddedio/DataCollection.F90 +++ b/griddedio/DataCollection.F90 @@ -107,7 +107,7 @@ function find(this, file_name, rc) result(metadata) deallocate(metadata) metadata => this%metadatas%back() dimensions => metadata%get_dimensions() - tile_size => dimensions%at("num_tiles") + tile_size => dimensions%at("tile_index") skip_grid = associated(tile_size) if ( (.not. allocated(this%src_grid)) .and. (.not. skip_grid)) then From fb3663bdc8face1914967194f0f3d0f94cd41c3b Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 26 Jul 2023 12:44:53 -0400 Subject: [PATCH 86/93] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3179dc09eed7..1925a6939bd8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Add ability of ExtData to fill variables on MAPL "tile" grids. - Added print of regrid method during History initialization - Added ability to use an `ESMF.rc` file to pass in pre-`ESMF_Initialize` options to ESMF (see [ESMF Docs](https://earthsystemmodeling.org/docs/release/latest/ESMF_refdoc/node4.html#SECTION04024000000000000000) for allowed flags. - NOTE: File *must* be called `ESMF.rc` From dc3d0cf3408c30e2acd5b5140bd9a7419a3f9424 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 26 Jul 2023 12:57:14 -0400 Subject: [PATCH 87/93] remove commented line --- base/NCIO.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index ddf0a1b26f0d..acae844fe9ce 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -40,7 +40,6 @@ module NCIOMod public MAPL_VarRead public MAPL_VarWrite public get_fname_by_face - !public MAPL_TileMaskGet public MAPL_NCIOGetFileType public MAPL_VarReadNCPar public MAPL_VarWriteNCPar From bf53884f926ba20c570ced07772ca6967e585135 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Wed, 26 Jul 2023 15:43:29 -0400 Subject: [PATCH 88/93] Update griddedio/TileIO.F90 Co-authored-by: Tom Clune --- griddedio/TileIO.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/griddedio/TileIO.F90 b/griddedio/TileIO.F90 index 85fbaffcbf44..7b55aca9609c 100644 --- a/griddedio/TileIO.F90 +++ b/griddedio/TileIO.F90 @@ -13,6 +13,7 @@ module MAPL_TileIOMod private type, public :: MAPL_TileIO + private type(ESMF_FieldBundle) :: bundle integer :: read_collection_id type(tile_buffer), allocatable :: tile_buffer(:) From a00193a86658f088c094f7b751a1537bac80591a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 27 Jul 2023 12:11:42 -0400 Subject: [PATCH 89/93] Update to Baselibs 7.14.0 --- .circleci/config.yml | 2 +- .github/workflows/workflow.yml | 4 +- CHANGELOG.md | 29 +++++++++----- CMakeLists.txt | 40 ++++++++++--------- Ford/docs-with-remote-esmf.md | 1 - ...th-remote-esmf.public_private_protected.md | 1 - components.yaml | 4 +- geom/CMakeLists.txt | 1 - gridcomps/ExtData2G/CMakeLists.txt | 2 +- .../ExtData2G/ExtDataAbstractFileHandler.F90 | 23 +++++------ gridcomps/ExtData2G/ExtDataConfig.F90 | 9 ++--- gridcomps/ExtData2G/ExtDataDerived.F90 | 9 ++--- gridcomps/ExtData2G/ExtDataFileStream.F90 | 7 ++-- .../ExtData2G/ExtDataOldTypesCreator.F90 | 1 - gridcomps/ExtData2G/ExtDataRule.F90 | 13 +++--- gridcomps/ExtData2G/ExtDataSample.F90 | 9 ++--- pfio/MultiGroupServer.F90 | 6 +-- 17 files changed, 82 insertions(+), 79 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 59e23e5b779b..0d50a8c5d870 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -16,7 +16,7 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 -baselibs_version: &baselibs_version v7.13.0 +baselibs_version: &baselibs_version v7.14.0 bcs_version: &bcs_version v11.1.0 tag_build_arg_name: &tag_build_arg_name maplversion diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index b73ba9bbbcfa..9fc137bb07da 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.13.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.14.0-openmpi_4.1.4-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -77,7 +77,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.13.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.14.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CHANGELOG.md b/CHANGELOG.md index 1925a6939bd8..003e23cf46d6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,23 +29,32 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Updates to GFE library dependency + - Require gFTL v1.10.0 + - Require gFTL-shared v1.6.1 + - Require fArgParse v1.5.0 + - Require pFlogger v1.9.5 + - Removed yaFyaml as dependency - Updated programs using FLAP for command line parsing to use fArgParse instead -- Updated `components.yaml` to match GEOSgcm v11.1.0 - - ESMA_env v4.9.1 → v4.17.0 - - Baselibs 7.13.0 - - esmf v8.5.0b22 - - GFE v1.10.0 - - curl 8.1.1 +- Updated `components.yaml` to use Baselibs 7.14.0 + - ESMA_env v4.9.1 → v4.18.0 + - Baselibs 7.14.0 + - esmf v8.5.0 + - GFE v1.11.0 + - curl 8.2.1 - HDF5 1.10.10 - netCDF-C 4.9.2 - netCDF-Fortran 4.6.1 - - CDO 2.2.0 - - NCO 5.1.5 + - CDO 2.2.1 + - NCO 5.1.7 - Move to MPT 2.28 at NAS, and other various changes for TOSS4 at NAS - - ESMA_cmake v3.28.0 → v3.29.0 + - Remove Haswell from `build.csh` + - ESMA_cmake v3.28.0 → v3.31.0 - Clean up for TOSS4 changes at NAS + - Add `QUIET_DEBUG` flag + - Suppress some common warnings with Intel Debug - Make the GEOSadas CI build separate as it often fails due to race conditions in GSI -- Update CI to use BCs v11.1.0 +- Update CI to use BCs v11.1.0 and Baselibs 7.14.0 - Updates to support building MAPL with spack instead of Baselibs - Add `FindESMF.cmake` file to `cmake` directory (as it can't easily be found via spack) - Move `CMAKE_MODULE_PATH` append statement up to find `FindESMF.cmake` before we `find_package(ESMF)` diff --git a/CMakeLists.txt b/CMakeLists.txt index c12b20b235f0..a4b80203da10 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -73,38 +73,40 @@ message (STATUS "Building MAPL as ${MAPL_LIBRARY_TYPE} libraries") # This would then populate the target already leading to find_package() # errors. if(NOT TARGET GFTL::gftl) - # MAPL currently requires at least GFTL 1.5.1 - find_package(GFTL 1.5.1 REQUIRED) + find_package(GFTL 1.10.0 REQUIRED) else() - if (GFTL_VERSION VERSION_LESS 1.5.1) - message(FATAL_ERROR "GFTL must be at least 1.5.1") + if (GFTL_VERSION VERSION_LESS 1.10.0) + message(FATAL_ERROR "gFTL must be at least 1.10.0") endif () endif() +message (STATUS "Found gFTL: ${GFTL_DIR} (found version ${GFTL_VERSION})") + if(NOT TARGET GFTL_SHARED::gftl-shared) - find_package(GFTL_SHARED REQUIRED) + # MAPL currently requires at least gFTL-shared 1.6.1 + find_package(GFTL_SHARED 1.6.1 REQUIRED) +else () + if (GFTL_SHARED_VERSION VERSION_LESS 1.6.1) + message(FATAL_ERROR "gFTL-shared must be at least 1.6.1") + endif () endif() +message (STATUS "Found gFTL-shared: ${GFTL_DIR} (found version ${GFTL_SHARED_VERSION})") option(BUILD_WITH_FARGPARSE "Use fArgParse for command line processing" ON) if(BUILD_WITH_FARGPARSE) if(NOT TARGET FARGPARSE::fargparse) - find_package(FARGPARSE 1.4.1 REQUIRED) + find_package(FARGPARSE 1.5.0 REQUIRED) else() - if (FARGPARSE_VERSION VERSION_LESS 1.4.1) - message(FATAL_ERROR "fArgParse must be at least 1.4.1") + if (FARGPARSE_VERSION VERSION_LESS 1.5.0) + message(FATAL_ERROR "fArgParse must be at least 1.5.0") endif () endif() + message (STATUS "Building with fArgParse") + message (STATUS "Found fArgParse: ${FARGPARSE_DIR} (found version ${FARGPARSE_VERSION})") endif() option(USE_EXTDATA2G "Use ExtData2G" ON) if(USE_EXTDATA2G) set (EXTDATA2G_TARGET "MAPL.ExtData2G" CACHE STRING "ExtData2G Target") - if(NOT TARGET YAFYAML::yafyaml) - find_package(YAFYAML 1.0.4 REQUIRED) - else() - if (YAFYAML_VERSION VERSION_LESS 1.0.4) - message(FATAL_ERROR "yaFyaml must be at least 1.0.4") - endif () - endif() message (STATUS "Building with ExtData2G") else() set (EXTDATA2G_TARGET "" CACHE STRING "ExtData2G Target") @@ -113,12 +115,14 @@ endif() option(BUILD_WITH_PFLOGGER "Build MAPL with pFlogger library support" ON) if (BUILD_WITH_PFLOGGER) if(NOT TARGET PFLOGGER::pflogger) - find_package(PFLOGGER 1.9.1 REQUIRED) + find_package(PFLOGGER 1.9.5 REQUIRED) else() - if (PFLOGGER_VERSION VERSION_LESS 1.9.1) - message(FATAL_ERROR "pFlogger must be at least 1.9.1") + if (PFLOGGER_VERSION VERSION_LESS 1.9.5) + message(FATAL_ERROR "pFlogger must be at least 1.9.5") endif () endif() + message (STATUS "Building with pFlogger") + message (STATUS "Found pFlogger: ${PFLOGGER_DIR} (found version ${PFLOGGER_VERSION})") endif() option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) diff --git a/Ford/docs-with-remote-esmf.md b/Ford/docs-with-remote-esmf.md index f6758647794e..0cebe66900a0 100644 --- a/Ford/docs-with-remote-esmf.md +++ b/Ford/docs-with-remote-esmf.md @@ -21,7 +21,6 @@ exclude_dir: ../Ford ../build ../gFTL ../esmf - ../yaFyaml ../pFUnit ../fArgParse ../pFlogger diff --git a/Ford/docs-with-remote-esmf.public_private_protected.md b/Ford/docs-with-remote-esmf.public_private_protected.md index fdbcf328c2d2..7b0e96d4f8ef 100644 --- a/Ford/docs-with-remote-esmf.public_private_protected.md +++ b/Ford/docs-with-remote-esmf.public_private_protected.md @@ -22,7 +22,6 @@ exclude_dir: ../Ford ../build ../gFTL ../esmf - ../yaFyaml ../pFUnit ../fArgParse ../pFlogger diff --git a/components.yaml b/components.yaml index 1a9d754c9506..cba1896341fe 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.17.0 + tag: v4.18.0 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.29.0 + tag: v3.31.0 develop: develop ecbuild: diff --git a/geom/CMakeLists.txt b/geom/CMakeLists.txt index d61a49483989..ee50231021fb 100644 --- a/geom/CMakeLists.txt +++ b/geom/CMakeLists.txt @@ -30,7 +30,6 @@ endif () esma_add_library(${this} SRCS ${srcs} -# DEPENDENCIES MAPL.oomph MAPL.shared MAPL.profiler MAPL.base YAFYAML::yafyaml PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL::gftl-v2 DEPENDENCIES MAPL.shared PFLOGGER::pflogger TYPE ${MAPL_LIBRARY_TYPE} ) diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 286af145629d..ef069b2e6e54 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -24,7 +24,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.base MAPL.generic MAPL.griddedio TYPE SHARED) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared YAFYAML::yafyaml esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) target_include_directories (${this} PUBLIC $) diff --git a/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 b/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 index 2ade22e98162..f1098f1dc175 100644 --- a/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 +++ b/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 @@ -3,7 +3,6 @@ #include "unused_dummy.H" module MAPL_ExtdataAbstractFileHandler use ESMF - use yafYaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ExtDataBracket @@ -28,7 +27,7 @@ module MAPL_ExtdataAbstractFileHandler type(ESMF_Time), allocatable :: valid_range(:) logical :: persist_closest contains - procedure :: initialize + procedure :: initialize procedure :: make_metadata procedure :: get_time_on_file procedure(get_file_bracket), deferred :: get_file_bracket @@ -48,7 +47,7 @@ subroutine get_file_bracket(this, input_time, source_time, bracket, fail_on_miss end subroutine get_file_bracket end interface - + contains subroutine initialize(this,file_series,persist_closest,unusable,rc) @@ -93,7 +92,7 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out type(ESMF_Time), allocatable :: time_series(:) logical :: in_bounds, found_time, wrap_ integer :: i,num_times - + _UNUSED_DUMMY(unusable) if (present(wrap)) then wrap_= .true. @@ -105,7 +104,7 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out _RETURN(_SUCCESS) end if - call this%make_metadata(filename,file_metadata,_RC) + call this%make_metadata(filename,file_metadata,_RC) call file_metadata%get_time_info(timeVector=time_series,_RC) num_times = size(time_series) found_time = .false. @@ -120,14 +119,14 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out exit end if enddo - else + else if (wrap_) then output_time=time_series(num_times) time_index = num_times found_time = .true. - wrap = -1 + wrap = -1 end if - end if + end if else if (bracketside == 'R') then in_bounds = .not.(target_time >= time_series(num_times)) if (in_bounds) then @@ -139,12 +138,12 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out exit end if enddo - else + else if (wrap_) then output_time=time_series(1) time_index = 1 found_time = .true. - wrap = 1 + wrap = 1 end if end if else @@ -161,11 +160,11 @@ subroutine make_metadata(this,file,metadata,rc) type(FileMetadataUtils), pointer, intent(inout) :: metadata integer, optional, intent(out ) :: rc type(MAPLDataCollection), pointer :: collection => null() - + Collection => DataCollections%at(this%collection_id) metadata => collection%find(file) _RETURN(_SUCCESS) end subroutine make_metadata - + end module MAPL_ExtdataAbstractFileHandler diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index d6ed815ece2f..086476a761fe 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -1,7 +1,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataConfig use ESMF - use yaFyaml use PFIO use gFTL_StringVector use MAPL_KeywordEnforcerMod @@ -93,7 +92,7 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) - single_sample = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + single_sample = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) ts = ExtDataTimeSample(single_sample,_RC) call ext_config%sample_map%insert(trim(hconfig_key),ts) enddo @@ -108,7 +107,7 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) temp_ds => ext_config%file_stream_map%at(hconfig_key) _ASSERT(.not.associated(temp_ds),"defined duplicate named collection") - single_collection = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + single_collection = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) ds = ExtDataFileStream(single_collection,current_time,_RC) call ext_config%file_stream_map%insert(trim(hconfig_key),ds) enddo @@ -133,7 +132,7 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ new_key = hconfig_key//rule_sep//i_char call ext_config%add_new_rule(new_key,rule_map,multi_rule=.true.,_RC) enddo - else + else _FAIL("Unsupported type") end if enddo @@ -419,7 +418,7 @@ function has_rule_for(this,base_name,rc) result(found_rule) found_rule = (key(:rule_sep_loc-1) == base_name) else found_rule = (key == base_name) - end if + end if if (found_rule) exit call iter%next() enddo diff --git a/gridcomps/ExtData2G/ExtDataDerived.F90 b/gridcomps/ExtData2G/ExtDataDerived.F90 index af926e9117b0..e538f220925c 100644 --- a/gridcomps/ExtData2G/ExtDataDerived.F90 +++ b/gridcomps/ExtData2G/ExtDataDerived.F90 @@ -2,7 +2,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataDerived use ESMF - use yaFyaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use gFTL_StringVector @@ -40,7 +39,7 @@ function new_ExtDataDerived(config,unusable,rc) result(rule) if (allocated(tempc)) deallocate(tempc) is_present = ESMF_HConfigIsDefined(config,keyString="function",_RC) - _ASSERT(is_present,"no expression found in derived entry") + _ASSERT(is_present,"no expression found in derived entry") if (is_present) then tempc = ESMF_HConfigAsString(config,keyString="function",_RC) rule%expression=tempc @@ -67,14 +66,14 @@ function get_variables_in_expression(this,rc) result(variables_in_expression) if (index(this%expression,"mask")/=0) then allocate(temp_mask) temp_mask = ExtDataMask(this%expression) - variables_in_expression = temp_mask%get_mask_variables(_RC) + variables_in_expression = temp_mask%get_mask_variables(_RC) else variables_in_expression = parser_variables_in_expression(this%expression,_RC) end if _RETURN(_SUCCESS) end function - + subroutine set_defaults(this,unusable,rc) class(ExtDataDerived), intent(inout), target :: this @@ -90,7 +89,7 @@ subroutine display(this) class(ExtDataDerived) :: this write(*,*)"function: ",trim(this%expression) end subroutine display - + end module MAPL_ExtDataDerived module MAPL_ExtDataDerivedMap diff --git a/gridcomps/ExtData2G/ExtDataFileStream.F90 b/gridcomps/ExtData2G/ExtDataFileStream.F90 index efb53581b65c..ba6523224a34 100644 --- a/gridcomps/ExtData2G/ExtDataFileStream.F90 +++ b/gridcomps/ExtData2G/ExtDataFileStream.F90 @@ -2,7 +2,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataFileStream use ESMF - use yaFyaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_TimeStringConversion @@ -30,7 +29,7 @@ module MAPL_ExtDataFileStream end interface ExtDataFileStream contains - function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) + function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) type(ESMF_HConfig), intent(in) :: config type(ESMF_Time), intent(in) :: current_time class(KeywordEnforcer), optional, intent(in) :: unusable @@ -56,7 +55,7 @@ function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) file_reff_time = get_string_with_default(config,"ref_time") range_str = get_string_with_default(config,"valid_range") end if - + if (file_frequency /= '') then data_set%frequency = string_to_esmf_timeinterval(file_frequency) else @@ -160,7 +159,7 @@ subroutine detect_metadata(this,metadata_out,time,multi_rule,get_range,rc) logical, optional, intent(in) :: get_range integer, optional, intent(out) :: rc - logical :: get_range_ + logical :: get_range_ type(MAPLDataCollection), pointer :: collection type(FileMetadataUtils), pointer :: metadata type(ESMF_Time), allocatable :: time_series(:) diff --git a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 index f84d2936eafe..f6e4533b2f2c 100644 --- a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 +++ b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 @@ -4,7 +4,6 @@ module MAPL_ExtDataOldTypesCreator use ESMF use MAPL_BaseMod - use yafYaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ExtDataTypeDef diff --git a/gridcomps/ExtData2G/ExtDataRule.F90 b/gridcomps/ExtData2G/ExtDataRule.F90 index d579c5656a3f..44b4e7a752f8 100644 --- a/gridcomps/ExtData2G/ExtDataRule.F90 +++ b/gridcomps/ExtData2G/ExtDataRule.F90 @@ -1,6 +1,5 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataRule - use yaFyaml use ESMF use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling @@ -74,7 +73,7 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru end if if (ESMF_HConfigIsDefined(config,keyString="sample")) then - + config1 = ESMF_HConfigCreateAt(config,keyString="sample",_RC) if (ESMF_HConfigIsMap(config1)) then ts = ExtDataTimeSample(config1,_RC) @@ -83,7 +82,7 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru else rule%sample_key=ESMF_HConfigAsString(config1,_RC) end if - else + else rule%sample_key = "" end if @@ -94,12 +93,12 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru else allocate(rule%linear_trans,source=[0.0,0.0]) end if - + if (allocated(tempc)) deallocate(tempc) if (ESMF_HConfigIsDefined(config,keyString="regrid")) then tempc = ESMF_HConfigAsString(config,keyString="regrid",_RC) rule%regrid_method=tempc - else + else rule%regrid_method="BILINEAR" end if @@ -111,7 +110,7 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru if (ESMF_HConfigIsDefined(config,keyString="fail_on_missing_file")) then rule%fail_on_missing_file = ESMF_HConfigAsLogical(config,keyString="fail_on_missing_file",_RC) end if - + rule%multi_rule=usable_multi_rule _RETURN(_SUCCESS) @@ -137,7 +136,7 @@ subroutine split_vector(this,original_key,ucomp,vcomp,unusable,rc) integer, optional, intent(out) :: rc integer :: semi_pos character(len=:),allocatable :: uname,vname - + _UNUSED_DUMMY(unusable) semi_pos = index(this%file_var,";") diff --git a/gridcomps/ExtData2G/ExtDataSample.F90 b/gridcomps/ExtData2G/ExtDataSample.F90 index ebdbfc534cb9..e7d9c6ce168f 100644 --- a/gridcomps/ExtData2G/ExtDataSample.F90 +++ b/gridcomps/ExtData2G/ExtDataSample.F90 @@ -1,6 +1,5 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataTimeSample - use yaFyaml use ESMF use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling @@ -75,10 +74,10 @@ function new_ExtDataTimeSample(config,unusable,rc) result(TimeSample) allocate(TimeSample%source_time(2)) TimeSample%source_time(1)=string_to_esmf_time(source_str(:idx-1)) TimeSample%source_time(2)=string_to_esmf_time(source_str(idx+1:)) - else + else if (.not.allocated(TimeSample%source_time)) allocate(TimeSample%source_time(0)) end if - + _RETURN(_SUCCESS) end function new_ExtDataTimeSample @@ -89,14 +88,14 @@ subroutine set_defaults(this,unusable,rc) class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status + integer :: status _UNUSED_DUMMY(unusable) this%time_interpolation=.true. this%extrap_outside='none' this%refresh_time="00" this%refresh_frequency="PT0S" this%refresh_offset="PT0S" - if (allocated(this%source_time)) then + if (allocated(this%source_time)) then deallocate(this%source_time,stat=status) _VERIFY(status) end if diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index bc2220dccaf0..45fd8d5722b4 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -46,7 +46,7 @@ module pFIO_MultiGroupServerMod use pFIO_AbstractRequestHandleMod use pFIO_FileMetadataMod use pFIO_IntegerMessageMapMod - use gFTL2_StringSet, StringSetIterator =>SetIterator + use gFTL2_StringSet use mpi use pFlogger, only: logging, Logger @@ -560,9 +560,9 @@ subroutine dispatch_work(collection_id, idleRank, num_idlePEs, FileName, rc) enddo ! if there is no idle processor, get back to probe if (all(num_idlePEs == 0)) cycle - ! if this file is still being written, get back to probe + ! if this file is still being written, get back to probe iter = FilesBeingWritten%find(FileName) - if (iter /= FilesBeingWritten%end()) cycle + if (iter /= FilesBeingWritten%end()) cycle ! get the node with the most idle processors node_rank = maxloc(num_idlePEs, dim=1) - 1 From b3135203215027318821d5d2bfa125765eae63e0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 27 Jul 2023 12:12:58 -0400 Subject: [PATCH 90/93] Remove ESMF beta check --- CHANGELOG.md | 1 - CMakeLists.txt | 24 ------------------------ 2 files changed, 25 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 003e23cf46d6..a6db68519365 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,7 +19,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - sampling IODA file with trajectory sampler (step-1): make it run - Convert ExtData to use ESMF HConfig for YAML parsing rather than YaFYAML - Set required ESMF version to 8.5.0 - - Add check in CMake to make sure ESMF version is at least 8.5.0b22 if using a beta snapshot - Add StationSamplerMod for station sampler - Added ReplaceMetadata message and method to replace oserver's metadata - Added field utilities to perform basic numeric operations on fields diff --git a/CMakeLists.txt b/CMakeLists.txt index a4b80203da10..c68f55f33091 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -172,30 +172,6 @@ else () endif () endif () -# Due to use of a feature of ESMF that came in with ESMF v8.5.0b22, -# a beta version of ESMF, we need to make sure that if we are using -# ESMF 8.5.0, that we are using at least ESMF 8.5.0b22. This is -# a temporary fix until ESMF 8.5.0 final is released. Our criterion are: -# 1. ESMF version is 8.5.0 (from ESMF_VERSION) -# 2. We are using a beta snapshot of ESMF (from ESMF_BETA_RELEASE) -# 3. The ESMF version is at least v8.5.0b22 (from ESMF_BETA_SNAPSHOT) - -if (ESMF_VERSION VERSION_EQUAL 8.5.0 AND ESMF_BETA_RELEASE) - # So now we are using a beta version of ESMF 8.5.0. We need to make sure - # that the version is at least 8.5.0b22. That version information - # is stored in ESMF_BETA_SNAPSHOT and is of the form "v8.5.0b22" - set (ESMF_BETA_SNAPSHOT_TARGET 22) - string(REGEX REPLACE "v8.5.0b([0-9]+)" "\\1" ESMF_BETA_SNAPSHOT_NUMBER ${ESMF_BETA_SNAPSHOT}) - if (ESMF_BETA_SNAPSHOT_NUMBER LESS ESMF_BETA_SNAPSHOT_TARGET) - message(FATAL_ERROR - "ERROR! ESMF version must be at least v8.5.0b22, but you are using ${ESMF_BETA_SNAPSHOT}\n" - "" - "This is due to the use of a feature of ESMF that came in with ESMF v8.5.0b22, a beta version of ESMF.\n" - "This is a temporary fix until stable ESMF 8.5.0 is released.\n" - ) - endif () -endif () - # We wish to add extra flags when compiling as Debug. We should only # do this if we are using esma_cmake since the flags are defined # there. Note that some flags like STANDARD_F18 might be available on From bf2b62a0a3f6f1e16e43d8ab7a33d97b0e8b7b4a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 27 Jul 2023 12:27:56 -0400 Subject: [PATCH 91/93] Move to use ESMA_env v4.19.0 --- CHANGELOG.md | 2 +- components.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a6db68519365..f8b7b315b048 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,7 +36,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Removed yaFyaml as dependency - Updated programs using FLAP for command line parsing to use fArgParse instead - Updated `components.yaml` to use Baselibs 7.14.0 - - ESMA_env v4.9.1 → v4.18.0 + - ESMA_env v4.9.1 → v4.19.0 - Baselibs 7.14.0 - esmf v8.5.0 - GFE v1.11.0 diff --git a/components.yaml b/components.yaml index cba1896341fe..6192688644d7 100644 --- a/components.yaml +++ b/components.yaml @@ -5,7 +5,7 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.18.0 + tag: v4.19.0 develop: main ESMA_cmake: From eb129165958f502587e691afeb9f049ac7971a2b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 28 Jul 2023 08:18:40 -0400 Subject: [PATCH 92/93] Prepare for MAPL 2.40.0 --- CHANGELOG.md | 13 ++++++++++++- CMakeLists.txt | 2 +- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f8b7b315b048..0015e6d3cc49 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,18 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +### Changed + +### Fixed + +### Removed + +### Deprecated + +## [2.40.0] - 2023-07-29 + +### Added + - Add ability of ExtData to fill variables on MAPL "tile" grids. - Added print of regrid method during History initialization - Added ability to use an `ESMF.rc` file to pass in pre-`ESMF_Initialize` options to ESMF (see [ESMF Docs](https://earthsystemmodeling.org/docs/release/latest/ESMF_refdoc/node4.html#SECTION04024000000000000000) for allowed flags. @@ -71,7 +83,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated - Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 - ## [2.39.7] - 2023-07-18 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index c68f55f33091..77c5469864d7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.39.7 + VERSION 2.40.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui From 3e23e8fc133864ae2b38f203209a1c0a217a163c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 28 Jul 2023 08:21:18 -0400 Subject: [PATCH 93/93] Fix up changelog --- CHANGELOG.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0015e6d3cc49..53d30a37ac5f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -78,11 +78,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Removed unneeded and confusing default in History Grid Comp (see #2081) - Fixes in CMake for fArgParse transition -### Removed - ### Deprecated - Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 + ## [2.39.7] - 2023-07-18 ### Fixed