From 291176d4d689de195e101e553b0d077b360f17b2 Mon Sep 17 00:00:00 2001 From: brian-eaton Date: Fri, 1 Mar 2019 12:38:39 -0700 Subject: [PATCH 001/331] update NF_ to NF90_ in mpas_io.F --- src/framework/mpas_io.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 2c17d3c661..4dffe8fe76 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -27,8 +27,8 @@ module mpas_io integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT character, parameter :: MPAS_CHAR_FILLVAL = achar(0) ! TODO: To be replaced with PIO_FILL_CHAR once PIO2 provides this variable #else - integer, parameter :: MPAS_INT_FILLVAL = NF_FILL_INT - character, parameter :: MPAS_CHAR_FILLVAL = achar(NF_FILL_CHAR) + integer, parameter :: MPAS_INT_FILLVAL = NF90_FILL_INT + character, parameter :: MPAS_CHAR_FILLVAL = NF90_FILL_CHAR #endif #ifdef USE_PIO2 @@ -39,9 +39,9 @@ module mpas_io #endif #else #ifdef SINGLE_PRECISION - real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = NF_FILL_FLOAT + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = NF90_FILL_FLOAT #else - real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = NF_FILL_DOUBLE + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = NF90_FILL_DOUBLE #endif #endif From bee92c0e245fbb24f4d9495257d6db07c3aff1f5 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 20 Mar 2019 14:40:58 -0600 Subject: [PATCH 002/331] Add new attribute, used_by, to namelist options needed by MPAS dycore in CAM This commit adds the attribute used_by="cam" to namelist options need by the MPAS-A dycore in CAM. A Python script (build_cam_namelists.py) included with the MPAS-A dycore in CAM may be used to extract all such namelist options and to build pieces of files needed by CAM to define namelists. For the CAM-MPAS Python script to extract an option, the enclosing nml_record tag must have used_by="cam", as must the nml tag itself. --- src/core_atmosphere/Registry.xml | 92 ++++++++++++++++---------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..359fbf51a5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -53,18 +53,18 @@ - - + - - @@ -89,169 +89,169 @@ description="Length of model simulation" possible_values="[DDD_]hh:mm:ss"/> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - @@ -274,8 +274,8 @@ possible_values="Integer valued, $\leq$ (\# MPI tasks) / config_pio_num_iotasks"/> - - + @@ -296,8 +296,8 @@ possible_values="Any valid filename"/> - - + @@ -308,18 +308,18 @@ possible_values=".true. or .false."/> - - + - - From aa5d8d92c2a5a5cc85c0f7a63a967b8f803be7c8 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 8 May 2019 13:52:27 -0600 Subject: [PATCH 003/331] Only access config_pio_stride and config_pio_num_iotasks when necessary In the mpas_framework_init_phase2 routine, the namelist options config_pio_stride and config_pio_num_iotasks were accessed regardless of whether MPAS was being run in a configuration that used an external PIO io_system or not. For stand-alone configurations, an external PIO io_system will generally not be available, in which case config_pio_stride and config_pio_num_iotasks must be accessible so that their values can be passed to mpas_io_init, where PIO is initialized. In coupled configurations, an external PIO io_system will often be provided by the driver, and a minimal MPAS Registry.xml file may omit config_pio_stride and config_pio_num_iotasks. Accordingly, the values of these non-existent namelist options must not be accessed in mpas_framework_init_phase2. Besides accessing config_pio_stride and config_pio_num_iotasks only when necessary, this commit also moves the access of config_calendar_type inside of an if-test on the presence of an external calendar. --- src/framework/mpas_framework.F | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 974e0935ca..717f761b6e 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -85,22 +85,31 @@ subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ call mpas_pool_set_error_level(MPAS_POOL_WARN) #endif - call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) - call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) - call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) - if (present(calendar)) then call mpas_timekeeping_init(calendar) else + call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) call mpas_timekeeping_init(config_calendar_type) end if - pio_num_iotasks = config_pio_num_iotasks - pio_stride = config_pio_stride - if (pio_num_iotasks == 0) then - pio_num_iotasks = domain % dminfo % nprocs + ! + ! Note: pio_num_iotasks and pio_stride are only used in MPAS_io_init if io_system is + ! not present. In stand-alone configurations, we expect that io_system will not + ! be present and that pio_num_iotasks and pio_stride will be available from + ! the namelist; in other systems, a PIO io_system may be provided. + ! + if (.not. present(io_system)) then + call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) + call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) + pio_num_iotasks = config_pio_num_iotasks + pio_stride = config_pio_stride + if (pio_num_iotasks == 0) then + pio_num_iotasks = domain % dminfo % nprocs + end if end if + domain % ioContext % dminfo => domain % dminfo + call MPAS_io_init(domain % ioContext, pio_num_iotasks, pio_stride, io_system) end subroutine mpas_framework_init_phase2!}}} From ac4e836b34f07f3468ee6ae2ef62d90d4f8eb2ae Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 9 May 2019 11:12:53 -0600 Subject: [PATCH 004/331] Add optional argument 'unitNumbers' to core % setup_log(...) routine The mpas_log_init routine takes an optional argument, unitNumbers, to specify which Fortran unit numbers to use for the output and error log files written by a core. The mpas_log_init routine is called by the core % setup_log routine, which previously did not have an argument for passing in logging unit numbers. This commit adds an optional argument, unitNumbers, to the core % setup_log routine, and it modifies the implementation of each core's setup_log routine to pass the optional unitNumbers argument to the mpas_log_init routine. The core % setup_log routine is called by the MPAS subdriver's mpas_init routine, and at present no changes are made to the mpas_init routine to pass optional unitNumbers to the core % setup_log routine. However, the changes in this commit do enable alternate implementations of mpas_init to supply unit numbers to be used for logging, e.g., in coupled systems where the coupler has already defined logging units for each component. --- src/core_atmosphere/mpas_atm_core_interface.F | 9 +++++---- src/core_init_atmosphere/mpas_init_atm_core_interface.F | 5 +++-- src/core_landice/mode_forward/mpas_li_core_interface.F | 9 +++++---- src/core_ocean/driver/mpas_ocn_core_interface.F | 9 +++++---- .../model_forward/mpas_seaice_core_interface.F | 9 +++++---- src/core_sw/mpas_sw_core_interface.F | 9 +++++---- src/core_test/mpas_test_core_interface.F | 9 +++++---- src/framework/mpas_core_types.inc | 3 ++- 8 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 6a9064c60f..3737996554 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -195,15 +195,16 @@ end function atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function atm_setup_log(logInfo, domain) result(iErr)!{{{ + function atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -212,7 +213,7 @@ function atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index 588dacdcb2..b92014fd16 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -255,7 +255,7 @@ end function init_atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ + function init_atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open @@ -264,6 +264,7 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -272,7 +273,7 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_landice/mode_forward/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F index 665be262f9..db27f38305 100644 --- a/src/core_landice/mode_forward/mpas_li_core_interface.F +++ b/src/core_landice/mode_forward/mpas_li_core_interface.F @@ -190,15 +190,16 @@ end function li_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function li_setup_log(logInfo, domain) result(iErr)!{{{ + function li_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -207,7 +208,7 @@ function li_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 0906754b93..13fb0f277a 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -483,15 +483,16 @@ end function ocn_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function ocn_setup_log(logInfo, domain) result(iErr)!{{{ + function ocn_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -500,7 +501,7 @@ function ocn_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_seaice/model_forward/mpas_seaice_core_interface.F b/src/core_seaice/model_forward/mpas_seaice_core_interface.F index b1d237609b..ef8ade111e 100644 --- a/src/core_seaice/model_forward/mpas_seaice_core_interface.F +++ b/src/core_seaice/model_forward/mpas_seaice_core_interface.F @@ -673,15 +673,16 @@ end function seaice_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function seaice_setup_log(logInfo, domain) result(iErr)!{{{ + function seaice_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -690,7 +691,7 @@ function seaice_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_sw/mpas_sw_core_interface.F b/src/core_sw/mpas_sw_core_interface.F index ce0b8d5fa1..7596acf82a 100644 --- a/src/core_sw/mpas_sw_core_interface.F +++ b/src/core_sw/mpas_sw_core_interface.F @@ -188,15 +188,16 @@ end function sw_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function sw_setup_log(logInfo, domain) result(iErr)!{{{ + function sw_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -205,7 +206,7 @@ function sw_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_test/mpas_test_core_interface.F b/src/core_test/mpas_test_core_interface.F index 9779cfba1a..c0bce7d7fc 100644 --- a/src/core_test/mpas_test_core_interface.F +++ b/src/core_test/mpas_test_core_interface.F @@ -222,15 +222,16 @@ end function test_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function test_setup_log(logInfo, domain) result(iErr)!{{{ + function test_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -239,7 +240,7 @@ function test_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/framework/mpas_core_types.inc b/src/framework/mpas_core_types.inc index df5ede54ab..a254e998e7 100644 --- a/src/framework/mpas_core_types.inc +++ b/src/framework/mpas_core_types.inc @@ -64,12 +64,13 @@ end interface abstract interface - function mpas_setup_log_function(logInfo, domain) result(iErr) + function mpas_setup_log_function(logInfo, domain, unitNumbers) result(iErr) import mpas_log_type import domain_type type (mpas_log_type), pointer, intent(inout) :: logInfo type (domain_type), pointer, intent(in) :: domain + integer, dimension(2), intent(in), optional :: unitNumbers integer :: iErr end function mpas_setup_log_function end interface From 0ddb2fd6e17355c9714d476ff759ac0367a29aab Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 16 May 2019 17:45:12 -0600 Subject: [PATCH 005/331] Add used_by="cam" attribute to Registry.xml entries for some physics, I/O options This commit adds the used_by="cam" attribute to namelist options in the MPAS-A Registry.xml file that are either needed during the block-setup process or during the dimension-setup process. Specifically, the attribute is added to the following: * config_number_of_blocks * config_explicit_proc_decomp * config_proc_decomp_file_prefix * input_soil_temperature_lag * num_soil_layers * months * noznlev * naerlev * camdim1 --- src/core_atmosphere/Registry.xml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 359fbf51a5..f7451ce093 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -280,17 +280,17 @@ description="Prefix of graph decomposition file, to be suffixed with the MPI task count" possible_values="Any valid filename"/> - - - @@ -1671,41 +1671,41 @@ - + - - - - - - From 62c40ca0c9bc81f837a733e4b902b97263ce144c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 16 May 2019 17:20:46 -0600 Subject: [PATCH 006/331] Enable soundings to handle non-existence of config_sounding_interval option When MPAS-Atmosphere is built as a dycore in other modeling systems (e.g, CAM/CESM), only a subset of the stand-alone MPAS-Atmosphere namelist options may be available. To avoid segfaults in the soundings diagnostic module due to the non-existence of the config_sounding_interval option in such cases, add extra logic in the soundings_setup routine to detect that this namelist option is not available and deactivate soundings just as we would if config_soundings_interval = 'none'. --- src/core_atmosphere/diagnostics/soundings.F | 28 +++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/diagnostics/soundings.F b/src/core_atmosphere/diagnostics/soundings.F index 68c331bd69..f07f21852a 100644 --- a/src/core_atmosphere/diagnostics/soundings.F +++ b/src/core_atmosphere/diagnostics/soundings.F @@ -50,8 +50,9 @@ module soundings !----------------------------------------------------------------------- subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) - use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info, MPAS_POOL_SILENT + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config, & + mpas_pool_get_error_level, mpas_pool_set_error_level use mpas_io_units, only : mpas_new_unit, mpas_release_unit use mpas_timekeeping, only : MPAS_timeInterval_type, MPAS_time_type, MPAS_set_timeInterval, & MPAS_get_clock_time, MPAS_add_clock_alarm, MPAS_NOW @@ -67,6 +68,7 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) character(len=StrKIND), pointer :: soundingInterval integer :: i, ierr + integer :: err_level integer :: sndUnit real (kind=RKIND) :: station_lat, station_lon character (len=StrKIND) :: tempstr @@ -87,8 +89,30 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) + ! + ! Query the config_sounding_interval namelist option without triggering + ! warning messages if no such option exists + ! + nullify(soundingInterval) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) call mpas_pool_get_config(configs, 'config_sounding_interval', soundingInterval) + call mpas_pool_set_error_level(err_level) + + ! + ! If the config_sounding_interval namelist option was not found, just return + ! This may happen if MPAS-A is built within another system where, e.g., only + ! dynamics namelist options are available + ! + if (.not. associated(soundingInterval)) then + call mpas_log_write('config_sounding_interval is not a namelist option...') + return + end if + ! + ! If the config_sounding_interval namelist option is 'none', no soundings + ! will to be produced + ! if (trim(soundingInterval) == 'none') then return end if From f5dcc368ea485d621bbea68709cf3b8745c03656 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 8 May 2019 13:52:27 -0600 Subject: [PATCH 007/331] Only access config_pio_stride and config_pio_num_iotasks when necessary In the mpas_framework_init_phase2 routine, the namelist options config_pio_stride and config_pio_num_iotasks were accessed regardless of whether MPAS was being run in a configuration that used an external PIO io_system or not. For stand-alone configurations, an external PIO io_system will generally not be available, in which case config_pio_stride and config_pio_num_iotasks must be accessible so that their values can be passed to mpas_io_init, where PIO is initialized. In coupled configurations, an external PIO io_system will often be provided by the driver, and a minimal MPAS Registry.xml file may omit config_pio_stride and config_pio_num_iotasks. Accordingly, the values of these non-existent namelist options must not be accessed in mpas_framework_init_phase2. Besides accessing config_pio_stride and config_pio_num_iotasks only when necessary, this commit also moves the access of config_calendar_type inside of an if-test on the presence of an external calendar. --- src/framework/mpas_framework.F | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 974e0935ca..f55f56afac 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -85,22 +85,36 @@ subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ call mpas_pool_set_error_level(MPAS_POOL_WARN) #endif - call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) - call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) - call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) - if (present(calendar)) then call mpas_timekeeping_init(calendar) else + call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) call mpas_timekeeping_init(config_calendar_type) end if - pio_num_iotasks = config_pio_num_iotasks - pio_stride = config_pio_stride + ! + ! Note: pio_num_iotasks and pio_stride are only used in MPAS_io_init if io_system is + ! not present. In stand-alone configurations, we expect that io_system will not + ! be present and that pio_num_iotasks and pio_stride will be available from + ! the namelist; in other systems, a PIO io_system may be provided. + ! + if (.not. present(io_system)) then + call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) + call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) + pio_num_iotasks = config_pio_num_iotasks + pio_stride = config_pio_stride + else + pio_num_iotasks = -1 ! Not used when external io_system is provided + pio_stride = -1 ! Not used when external io_system is provided + end if + + ! A value of 0 for pio_num_iotasks actually indicates that every task should be an I/O task if (pio_num_iotasks == 0) then pio_num_iotasks = domain % dminfo % nprocs end if + domain % ioContext % dminfo => domain % dminfo + call MPAS_io_init(domain % ioContext, pio_num_iotasks, pio_stride, io_system) end subroutine mpas_framework_init_phase2!}}} From e4c28190e5e7ace801c2e7bf6af2abac72592ef7 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Mon, 24 Jun 2019 08:34:23 -0600 Subject: [PATCH 008/331] Fixes byte to string conversion python3 error Python3 treats supprocess.check_output as a byte, which is no longer strictly equivalent to a string as in python2. Consequently, conversion is needed for equivalence between the strings for the python3 migration. --- testing_and_setup/compass/clean_testcase.py | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/testing_and_setup/compass/clean_testcase.py b/testing_and_setup/compass/clean_testcase.py index 99d4034384..9aa66f806f 100755 --- a/testing_and_setup/compass/clean_testcase.py +++ b/testing_and_setup/compass/clean_testcase.py @@ -84,7 +84,7 @@ regex = re.compile('(\d):') core_configuration = subprocess.check_output(['./list_testcases.py']) - for line in core_configuration.split('\n'): + for line in core_configuration.decode('utf-8').split('\n'): if regex.search(line) is not None: conf_arr = line.replace(":", " ").split() case_num = int(conf_arr[0]) @@ -103,7 +103,7 @@ os.chdir(os.path.dirname(os.path.realpath(__file__))) git_version = subprocess.check_output(['git', 'describe', '--tags', '--dirty']) - git_version = git_version.strip('\n') + git_version = git_version.decode('utf-8').strip('\n') os.chdir(old_dir) calling_command = "" write_history = False @@ -119,7 +119,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') args.core = config_options[1] args.configuration = config_options[3] args.resolution = config_options[5] @@ -194,7 +194,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') history_file.write('\n') history_file.write(' core: {}\n'.format(config_options[1])) history_file.write(' configuration: {}\n'.format( From bc8d63d31c6942c14eaacedfe946d19240b92c67 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 1 Oct 2018 21:16:54 +0000 Subject: [PATCH 009/331] Enable MPAS to be compiled into position-independent code In order to allow MPAS code to be called from other systems with more flexibility, e.g., as a shared library, this commit adds a new compile option, SHAREDLIB=true, that causes all source files to be compiled with appropriate flags to generate position-independent code. The appropriate flags to use are not known for all compilers with build targets in the top-level Makefile, and if SHAREDLIB=true is specified for such a build target, an error like the following will be generated: *** Position-independent code was requested but PIC flags are not available. Please add PIC flags for the 'ftn' target. Stop. --- Makefile | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/Makefile b/Makefile index 5fbaeca357..66a7346c59 100644 --- a/Makefile +++ b/Makefile @@ -23,6 +23,8 @@ xlf: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "PICFLAG = -qpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -44,6 +46,7 @@ ftn: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -62,6 +65,7 @@ titan-cray: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -87,6 +91,8 @@ pgi: "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -108,6 +114,7 @@ pgi-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -129,6 +136,7 @@ pgi-llnl: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -154,6 +162,8 @@ ifort: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -179,6 +189,7 @@ ifort-scorep: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -204,6 +215,7 @@ ifort-gcc: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -229,6 +241,8 @@ gfortran: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "PICFLAG = -fPIC" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -254,6 +268,7 @@ gfortran-clang: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -275,6 +290,7 @@ g95: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -296,6 +312,7 @@ pathscale-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -317,6 +334,7 @@ cray-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -340,6 +358,7 @@ gnu-nersc: "CFLAGS_DEBUG = -g -m64" \ "CXXFLAGS_DEBUG = -g -m64" \ "LDFLAGS_DEBUG = -g -m64" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "SERIAL = $(SERIAL)" \ @@ -365,6 +384,7 @@ intel-nersc: "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -traceback" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -390,6 +410,7 @@ bluegene: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -415,6 +436,8 @@ llvm: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -fopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -578,6 +601,23 @@ else # USE_PAPI IF PAPI_MESSAGE="Papi libraries are off." endif # USE_PAPI IF +# Only if this Makefile was invoked from a compiler target should we check that PICFLAG is set +ifneq "$(FC_SERIAL)" "" +ifeq "$(SHAREDLIB)" "true" +ifneq "$(PICFLAG)" "" + FFLAGS += $(PICFLAG) + CFLAGS += $(PICFLAG) + CXXFLAGS += $(PICFLAG) + LDFLAGS += $(PICFLAG) + SHAREDLIB_MESSAGE="Position-independent code was generated." +else +$(error Position-independent code was requested but PIC flags are not available. Please add PIC flags for the '$(BUILD_TARGET)' target) +endif +else + SHAREDLIB_MESSAGE="Position-dependent code was generated." +endif +endif + ifeq "$(USE_PIO2)" "true" PIO_MESSAGE="Using the PIO 2 library." else # USE_PIO2 IF @@ -809,6 +849,7 @@ endif @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) + @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @@ -892,6 +933,7 @@ errmsg: @echo " OPENMP=true - builds and links with OpenMP flags. Default is to not use OpenMP." @echo " USE_PIO2=true - links with the PIO 2 library. Default is to use the PIO 1.x library." @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." + @echo " SHAREDLIB=true - generate position-independent code suitable for use in a shared library. Default is false." @echo "" @echo "Ensure that NETCDF, PNETCDF, PIO, and PAPI (if USE_PAPI=true) are environment variables" @echo "that point to the absolute paths for the libraries." From ea13ea28408ea600e693a4246b8df817eb1e63ca Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 1 Jul 2019 13:55:58 -0600 Subject: [PATCH 010/331] Move domain_ptr and corelist from module variables to arguments in subdriver Towards the goal of supporting multiple instances of domains within a single simulation, this commit moves domain_ptr and corelist from module variables in the mpas_subdriver module to arguments to the mpas_init, mpas_run, and mpas_finalize routines. The main program (in mpas.F) now passes instances of a core_type and a domain_type to the subriver's mpas_init, mpas_run, and mpas_finalize routines. --- src/driver/mpas.F | 10 +++++++--- src/driver/mpas_subdriver.F | 22 ++++++++++++++-------- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/driver/mpas.F b/src/driver/mpas.F index 339a80303a..d0370fd577 100644 --- a/src/driver/mpas.F +++ b/src/driver/mpas.F @@ -8,14 +8,18 @@ program mpas use mpas_subdriver + use mpas_derived_types, only : core_type, domain_type implicit none - call mpas_init() + type (core_type), pointer :: corelist => null() + type (domain_type), pointer :: domain => null() - call mpas_run() + call mpas_init(corelist, domain) - call mpas_finalize() + call mpas_run(domain) + + call mpas_finalize(corelist, domain) stop diff --git a/src/driver/mpas_subdriver.F b/src/driver/mpas_subdriver.F index 1952010044..b224e415d9 100644 --- a/src/driver/mpas_subdriver.F +++ b/src/driver/mpas_subdriver.F @@ -35,14 +35,11 @@ module mpas_subdriver use test_core_interface #endif - type (core_type), pointer :: corelist => null() - type (dm_info), pointer :: dminfo - type (domain_type), pointer :: domain_ptr contains - subroutine mpas_init() + subroutine mpas_init(corelist, domain_ptr, mpi_comm) use mpas_stream_manager, only : MPAS_stream_mgr_init, MPAS_build_stream_filename, MPAS_stream_mgr_validate_streams use iso_c_binding, only : c_char, c_loc, c_ptr, c_int @@ -53,6 +50,10 @@ subroutine mpas_init() implicit none + type (core_type), intent(inout), pointer :: corelist + type (domain_type), intent(inout), pointer :: domain_ptr + integer, intent(in), optional :: mpi_comm + integer :: iArg, nArgs logical :: readNamelistArg, readStreamsArg character(len=StrKIND) :: argument, namelistFile, streamsFile @@ -154,7 +155,7 @@ end subroutine xml_stream_get_attributes ! ! Initialize infrastructure ! - call mpas_framework_init_phase1(domain_ptr % dminfo) + call mpas_framework_init_phase1(domain_ptr % dminfo, mpi_comm=mpi_comm) #ifdef CORE_ATMOSPHERE @@ -338,10 +339,12 @@ end subroutine xml_stream_get_attributes end subroutine mpas_init - subroutine mpas_run() + subroutine mpas_run(domain_ptr) implicit none + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr iErr = domain_ptr % core % core_run(domain_ptr) @@ -352,13 +355,16 @@ subroutine mpas_run() end subroutine mpas_run - subroutine mpas_finalize() + subroutine mpas_finalize(corelist, domain_ptr) use mpas_stream_manager, only : MPAS_stream_mgr_finalize - use mpas_log, only : mpas_log_finalize + use mpas_log, only : mpas_log_finalize, mpas_log_info implicit none + type (core_type), intent(inout), pointer :: corelist + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr From 6407091f9674d48ee8aae944e1701b3e122ab700 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 1 Jul 2019 16:13:42 -0600 Subject: [PATCH 011/331] Reserve some unit numbers for unformatted I/O The mpas_io_units module now reserves the upper part of the range of possible unit numbers for unformatted I/O. An unformatted I/O unit can be requested with the optional 'unformatted' argument to mpas_new_unit. Having specific unit numbers reserved for unformatted I/O is helpful in cases where the compiler is able to use environment variables to set the endianness or other properties based on unit number. For example, one could request that units 95, 96, 97, 98, and 99 perform unformatted I/O using big-endian byte order. --- src/framework/mpas_io_units.F | 42 ++++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/src/framework/mpas_io_units.F b/src/framework/mpas_io_units.F index 579c8ffc23..8568a9eaa5 100644 --- a/src/framework/mpas_io_units.F +++ b/src/framework/mpas_io_units.F @@ -21,8 +21,19 @@ module mpas_io_units use mpas_kind_types - integer, parameter, private :: maxUnits = 99 - logical, dimension(0:maxUnits), private, save :: unitsInUse + implicit none + + private + + integer, parameter :: maxUnits = 99 + logical, dimension(0:maxUnits), save :: unitsInUse + + ! Units reserved for unformatted I/O + integer, parameter :: unformatted_min = 95 + integer, parameter :: unformatted_max = maxUnits + + public :: mpas_new_unit, & + mpas_release_unit contains @@ -38,14 +49,30 @@ module mpas_io_units !> the unit number ! !----------------------------------------------------------------------- - subroutine mpas_new_unit(newUnit)!{{{ + subroutine mpas_new_unit(newUnit, unformatted)!{{{ + integer, intent(inout) :: newUnit + logical, optional, intent(in) :: unformatted - integer :: i + integer :: i, minsearch, maxsearch logical :: opened - do i = 1, maxUnits + newUnit = -1 + + ! + ! Determine the range over which to search for an unused unit + ! + minsearch = 1 + maxsearch = unformatted_min - 1 + if ( present(unformatted) ) then + if ( unformatted ) then + minsearch = unformatted_min + maxsearch = unformatted_max + end if + end if + + do i = minsearch, maxsearch if (.not. unitsInUse(i)) then inquire(i, opened=opened) if (opened) then @@ -72,9 +99,12 @@ end subroutine mpas_new_unit!}}} ! !----------------------------------------------------------------------- subroutine mpas_release_unit(releasedUnit)!{{{ + integer, intent(in) :: releasedUnit - unitsInUse(releasedUnit) = .false. + if (0 <= releasedUnit .and. releasedUnit <= maxUnits) then + unitsInUse(releasedUnit) = .false. + end if end subroutine mpas_release_unit!}}} From 7aacdd109aef1f5f0615df6ccb16fc7ae4d4b4f3 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 10 Jul 2019 11:26:09 -0600 Subject: [PATCH 012/331] Expand the range of unformatted unit numbers to [101,200] The range of unit numbers in the mpas_io_units module that were reserved for unformatted units was [95,99] in the previous commit. However, having just five units reserved for unformatted I/O may not be enough, particularly when multiple instances of MPAS domains are created, and a larger range of unformatted units may be necessary. This commit sets the range of unit numbers reserved for unformatted I/O to [101,200]. --- src/framework/mpas_io_units.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/mpas_io_units.F b/src/framework/mpas_io_units.F index 8568a9eaa5..acd3403b03 100644 --- a/src/framework/mpas_io_units.F +++ b/src/framework/mpas_io_units.F @@ -25,11 +25,11 @@ module mpas_io_units private - integer, parameter :: maxUnits = 99 + integer, parameter :: maxUnits = 200 logical, dimension(0:maxUnits), save :: unitsInUse ! Units reserved for unformatted I/O - integer, parameter :: unformatted_min = 95 + integer, parameter :: unformatted_min = 101 integer, parameter :: unformatted_max = maxUnits public :: mpas_new_unit, & From a8414e82718dca52c9e94e70a1e0b49161409338 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 10 Jul 2019 12:24:26 -0600 Subject: [PATCH 013/331] Use PHYSICS definition in diagnostics sub-Make and pre-processing of Registry.xml In order to allow for the use of any pre-processor definitions in the PHYSICS variable to be used in the pre-processing of the Registry.xml file and in the build of the diagnostics, the PHYSICS variable is now passed to the diagnostics sub-Make and added to the pre-processing line for the Registry.xml file. This commit also modifies the gen_includes target to depend on the existing core_reg target to generate the Registry_preprocessed.xml file, rather than duplicating the recipe from the core_reg target. --- src/core_atmosphere/Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 2e77cf8846..71fbbceec1 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -11,15 +11,14 @@ OBJS = mpas_atm_core.o \ all: physcore dycore diagcore atmcore utilities core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $(PHYSICS) Registry.xml > Registry_processed.xml core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi ( cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.atmosphere in_defaults=true ) ( cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.atmosphere stream_list.atmosphere. listed ) -gen_includes: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +gen_includes: core_reg (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) @@ -38,7 +37,7 @@ dycore: mpas_atm_dimensions.o physcore ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) diagcore: physcore dycore - ( cd diagnostics; $(MAKE) all ) + ( cd diagnostics; $(MAKE) all PHYSICS="$(PHYSICS)" ) utilities: physcore ( cd utils; $(MAKE) all ) From 3b8ca5f7e64f7a6b25090017ce7f7241c2882b51 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 10 Jul 2019 12:33:45 -0600 Subject: [PATCH 014/331] Pre-process out physics dimensions, pools, and options without -DDO_PHYSICS The inclusion of physics dimensions, pools, and namelist options in Registry files now depends on the definition of DO_PHYSICS being present in the pre-processing flags. Along with the exclusion of physics dimensions, pools, and options when DO_PHYSICS is not defined, references to the diag_physics and tend_physics pools, as well as physics namelist options, are now pre-processed out of the code. Some additional changes are needed to properly handle 'rthdynten' in the dynamics, since this field comes from the 'tend_physics' pool, which may not exist. Also, the PV diagnostics module now excludes code and fields for PV budgets when DO_PHYSICS is not defined, since these depend on fields from physics. ** NB: In order to correctly run with no physics, there are additional changes that are needed beyond those in this commit. Specifically, changes like those in 3ee9b34 (PR #193) are needed. --- src/core_atmosphere/Registry.xml | 62 +++++++++++++------ .../diagnostics/Registry_pv.xml | 8 ++- .../diagnostics/pv_diagnostics.F | 8 +++ .../dynamics/mpas_atm_time_integration.F | 19 +++--- src/core_atmosphere/mpas_atm_core.F | 22 ++++--- 5 files changed, 81 insertions(+), 38 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..05e8db8f36 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -32,6 +32,8 @@ description="The number of atmospheric layers"/> + +#ifdef DO_PHYSICS +#endif @@ -439,6 +442,8 @@ + +#ifdef DO_PHYSICS @@ -479,6 +484,7 @@ +#endif - - - - - - - @@ -588,6 +587,15 @@ + +#ifdef DO_PHYSICS + + + + + + + @@ -797,6 +805,7 @@ +#endif + +#ifdef DO_PHYSICS @@ -878,7 +889,6 @@ - @@ -917,6 +927,7 @@ +#endif - - - - - - - - - - - - @@ -997,6 +996,21 @@ +#ifdef DO_PHYSICS + + + + + + + + + + + + +#endif + @@ -1017,6 +1031,7 @@ +#ifdef DO_PHYSICS @@ -1024,6 +1039,7 @@ +#endif +#ifdef DO_PHYSICS +#endif +#ifdef DO_PHYSICS @@ -1395,6 +1414,7 @@ description="Volcanic (VOLC) aerosol concentration"/> +#endif @@ -1671,6 +1691,7 @@ +#ifdef DO_PHYSICS +#endif diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index fdf5d3b674..b2c16fac5f 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -20,6 +20,10 @@ + + +#ifdef DO_PHYSICS @@ -58,9 +62,7 @@ - - +#endif diff --git a/src/core_atmosphere/diagnostics/pv_diagnostics.F b/src/core_atmosphere/diagnostics/pv_diagnostics.F index da3d8fa605..6a0e61567b 100644 --- a/src/core_atmosphere/diagnostics/pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/pv_diagnostics.F @@ -13,8 +13,10 @@ module pv_diagnostics type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag +#ifdef DO_PHYSICS type (MPAS_pool_type), pointer :: tend type (MPAS_pool_type), pointer :: tend_physics +#endif type (MPAS_clock_type), pointer :: clock @@ -57,8 +59,10 @@ subroutine pv_diagnostics_setup(all_pools, simulation_clock) call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(all_pools, 'tend', tend) call mpas_pool_get_subpool(all_pools, 'tend_physics', tend_physics) +#endif clock => simulation_clock @@ -100,6 +104,7 @@ subroutine pv_diagnostics_compute() need_iLev_DT = MPAS_field_will_be_written('iLev_DT') need_any_diags = need_any_diags .or. need_iLev_DT +#ifdef DO_PHYSICS need_tend_lw = MPAS_field_will_be_written('depv_dt_lw') need_any_diags = need_any_diags .or. need_tend_lw need_any_budget = need_any_budget .or. need_tend_lw @@ -133,13 +138,16 @@ subroutine pv_diagnostics_compute() need_tend_fric_pv = MPAS_field_will_be_written('depv_dt_fric_pv') need_any_diags = need_any_diags .or. need_tend_fric_pv need_any_budget = need_any_budget .or. need_tend_fric_pv +#endif if (need_any_diags) then call atm_compute_pv_diagnostics(state, 1, diag, mesh) end if +#ifdef DO_PHYSICS if (need_any_budget) then call atm_compute_pvBudget_diagnostics(state, 1, diag, mesh, tend, tend_physics) end if +#endif end subroutine pv_diagnostics_compute diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f642d0fb15..f43be8c013 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -177,7 +177,7 @@ subroutine atm_srk3(domain, dt, itimestep) type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: tend - type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer :: tend_physics => null() type (field2DReal), pointer :: theta_m_field type (field3DReal), pointer :: scalars_field @@ -212,8 +212,6 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_config(domain % blocklist % configs, 'config_positive_definite', config_positive_definite) call mpas_pool_get_config(domain % blocklist % configs, 'config_monotonic', config_monotonic) call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', config_dt) - call mpas_pool_get_config(domain % blocklist % configs, 'config_microp_scheme', config_microp_scheme) - call mpas_pool_get_config(domain % blocklist % configs, 'config_convection_scheme', config_convection_scheme) call mpas_pool_get_config(domain % blocklist % configs, 'config_IAU_option', config_IAU_option) ! config variables for dynamics-transport splitting, WCS 18 November 2014 @@ -530,7 +528,9 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_subpool(block % structs, 'tend', tend) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) +#endif call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -1245,6 +1245,9 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_array(state, 'scalars', scalars_2, 2) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_config(block % configs, 'config_microp_scheme', config_microp_scheme) + call mpas_pool_get_config(block % configs, 'config_convection_scheme', config_convection_scheme) + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) @@ -3912,7 +3915,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, ! Dummy arguments ! type (mpas_pool_type), intent(inout) :: tend - type (mpas_pool_type), intent(inout) :: tend_physics + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh @@ -3943,8 +3946,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: rr_save - real (kind=RKIND), dimension(:,:), pointer :: tend_rtheta_adv ! needed for Tiedtke convection scheme - real (kind=RKIND), dimension(:,:), pointer :: rthdynten ! needed for Grell-Freitas convection scheme + real (kind=RKIND), dimension(:,:), pointer :: tend_rtheta_adv ! needed for Tiedtke convection scheme + real (kind=RKIND), dimension(:,:), pointer :: rthdynten => null() ! needed for Grell-Freitas convection scheme real (kind=RKIND), dimension(:,:,:), pointer :: scalars @@ -4029,7 +4032,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'exner', exner) call mpas_pool_get_array(diag, 'tend_rtheta_adv', tend_rtheta_adv) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + if (associated(tend_physics)) then + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + end if call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b431e9cc1c..57604b3678 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -516,7 +516,9 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call atm_compute_output_diagnostics(state, 1, diag, mesh) @@ -552,7 +554,9 @@ function atm_core_run(domain) result(ierr) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -621,10 +625,12 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'tend', tend) - call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) call atm_compute_output_diagnostics(state, 1, diag, mesh) block_ptr => block_ptr % next @@ -640,7 +646,9 @@ function atm_core_run(domain) result(ierr) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call atm_compute_restart_diagnostics(state, 1, diag, mesh) @@ -671,7 +679,9 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call atm_reset_diagnostics(diag, diag_physics) block_ptr => block_ptr % next @@ -693,12 +703,6 @@ function atm_core_run(domain) result(ierr) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) - block_ptr => domain % blocklist - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block_ptr % structs, 'state', state) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) - call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - end do end function atm_core_run @@ -814,14 +818,16 @@ subroutine atm_reset_diagnostics(diag, diag_physics) implicit none type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout) :: diag_physics + type (mpas_pool_type), pointer :: diag_physics real (kind=RKIND), dimension(:), pointer :: refl10cm_1km_max +#ifdef DO_PHYSICS call mpas_pool_get_array(diag_physics, 'refl10cm_1km_max', refl10cm_1km_max) if(associated(refl10cm_1km_max)) then refl10cm_1km_max(:) = 0. endif +#endif end subroutine atm_reset_diagnostics From 4cbca2b0675f53d69db8dca8338d3c9be033ac98 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Fri, 12 Jul 2019 13:36:05 -0600 Subject: [PATCH 015/331] * In ./src/core_atmosphere/diagnostics/Makefile, corrected typo. Changed line 27 to all: $(DIAGNOSTIC_MODULES) $(OBJS) --- src/core_atmosphere/diagnostics/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/diagnostics/Makefile b/src/core_atmosphere/diagnostics/Makefile index 9d83d39c6b..bd1adbaf68 100644 --- a/src/core_atmosphere/diagnostics/Makefile +++ b/src/core_atmosphere/diagnostics/Makefile @@ -24,7 +24,7 @@ soundings.o: OBJS = mpas_atm_diagnostics_manager.o mpas_atm_diagnostics_utils.o -all: $(DIAGNOSTIC_MODULS) $(OBJS) +all: $(DIAGNOSTIC_MODULES) $(OBJS) mpas_atm_diagnostics_manager.o: mpas_atm_diagnostics_utils.o $(DIAGNOSTIC_MODULES) From 0c1e87392f9c1e01bbac67d08bb5c47b399fa0da Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 31 Jul 2019 15:46:25 -0600 Subject: [PATCH 016/331] Allow mpas_bootstrap_framework_phase1 to use an externally provided PIO file_desc_t When MPAS is a component in a larger system, it may be necessary to "bootstrap" the MPAS infrastructure from an externally provided file descriptor. This commit adds an optional PIO file_desc_t argument to mpas_bootstrap_framework_phase1, which is then passed to MPAS_io_open. The MPAS_io_open routine now uses the optional PIO file_desc_t if provided, and opens the file indicated by the filename argument as before if no PIO file_desc_t argument is provided. --- src/framework/mpas_bootstrapping.F | 8 +++- src/framework/mpas_io.F | 69 ++++++++++++++++-------------- 2 files changed, 44 insertions(+), 33 deletions(-) diff --git a/src/framework/mpas_bootstrapping.F b/src/framework/mpas_bootstrapping.F index e87dadc077..6661620f35 100644 --- a/src/framework/mpas_bootstrapping.F +++ b/src/framework/mpas_bootstrapping.F @@ -76,13 +76,16 @@ module mpas_bootstrapping !> mpas_initialize_vectors() ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) !{{{ + subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype, pio_file_desc) !{{{ + + use pio, only : file_desc_t implicit none type (domain_type), pointer :: domain character(len=*), intent(in) :: mesh_filename integer, intent(in) :: mesh_iotype + type (file_desc_t), pointer, optional :: pio_file_desc type (block_type), pointer :: readingBlock @@ -147,7 +150,8 @@ subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) ! nHalos = config_num_halos - inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, ierr=ierr) + inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, & + pio_file_desc=pio_file_desc, ierr=ierr) if (ierr /= MPAS_IO_NOERR) then call mpas_log_write('Could not open input file '''//trim(mesh_filename)//''' to read mesh fields', MPAS_LOG_CRIT) else diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 2c17d3c661..4336c421f3 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -212,7 +212,8 @@ subroutine MPAS_io_unset_iotype(ioContext, ierr) end subroutine MPAS_io_unset_iotype - type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, clobber_file, truncate_file, ierr) + type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, & + clobber_file, truncate_file, pio_file_desc, ierr) implicit none @@ -222,6 +223,7 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon type (mpas_io_context_type), pointer :: ioContext logical, intent(in), optional :: clobber_file logical, intent(in), optional :: truncate_file + type (file_desc_t), pointer, optional :: pio_file_desc integer, intent(out), optional :: ierr integer :: pio_ierr, pio_iotype, pio_mode @@ -289,44 +291,49 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon end if end if - if (mode == MPAS_IO_WRITE) then + if (present(pio_file_desc)) then +call mpas_log_write('Using externally provided PIO file descriptor') + MPAS_io_open % pio_file = pio_file_desc + else + if (mode == MPAS_IO_WRITE) then !call mpas_log_write('MGD PIO_createfile') - if (ioContext % dminfo % my_proc_id == 0) then - inquire(file=trim(filename), exist=exists) - end if - call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) + if (ioContext % dminfo % my_proc_id == 0) then + inquire(file=trim(filename), exist=exists) + end if + call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) - ! If the file exists and we are not allowed to clobber it, return an - ! appropriate error code - if (exists .and. (.not. local_clobber)) then - if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER - return - end if + ! If the file exists and we are not allowed to clobber it, return an + ! appropriate error code + if (exists .and. (.not. local_clobber)) then + if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER + return + end if - if (exists .and. (.not. local_truncate)) then - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) - MPAS_io_open % preexisting_file = .true. - else - pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) + if (exists .and. (.not. local_truncate)) then + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) + MPAS_io_open % preexisting_file = .true. + else + pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) #ifdef MPAS_DEBUG - if (exists) then - call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) - end if + if (exists) then + call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) + end if #endif - end if - else - inquire(file=trim(filename), exist=exists) + end if + else + inquire(file=trim(filename), exist=exists) - if (.not. exists) then - if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + if (.not. exists) then + if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + return + end if +!call mpas_log_write('MGD PIO_openfile') + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) + endif + if (pio_ierr /= PIO_noerr) then + if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if -!call mpas_log_write('MGD PIO_openfile') - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) - endif - if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO - return end if if (mode == MPAS_IO_READ .or. MPAS_io_open % preexisting_file) then From ed8dbf6ff0cc9fbeb06a792ddc08d9210ce7121e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 8 Aug 2019 14:36:44 -0600 Subject: [PATCH 017/331] Don't call PIO_closefile in MPAS_io_close for externally provided PIO filedesc In order to avoid closing a PIO file_desc_t that was not opened by MPAS_io_open (because this external file_desc_t was provided as an optional argument in the call to MPAS_io_open), this commit adds a new member, external_file_desc, to the MPAS_IO_Handle_type type. This member is set to .true. if an external PIO file_desc_t was provided, and if .true. in the call to MPAS_io_close, PIO_closefile is not called. --- src/framework/mpas_io.F | 7 +++++-- src/framework/mpas_io_types.inc | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 4336c421f3..a3c4abc4f4 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -292,8 +292,8 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon end if if (present(pio_file_desc)) then -call mpas_log_write('Using externally provided PIO file descriptor') MPAS_io_open % pio_file = pio_file_desc + MPAS_io_open % external_file_desc = .true. else if (mode == MPAS_IO_WRITE) then !call mpas_log_write('MGD PIO_createfile') @@ -334,6 +334,7 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if + MPAS_io_open % external_file_desc = .false. end if if (mode == MPAS_IO_READ .or. MPAS_io_open % preexisting_file) then @@ -4883,7 +4884,9 @@ subroutine MPAS_io_close(handle, ierr) handle % initialized = .false. !call mpas_log_write('MGD PIO_closefile') - call PIO_closefile(handle % pio_file) + if (.not. handle % external_file_desc) then + call PIO_closefile(handle % pio_file) + end if end subroutine MPAS_io_close diff --git a/src/framework/mpas_io_types.inc b/src/framework/mpas_io_types.inc index 6cb61723e6..18e9d1454c 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -61,6 +61,7 @@ logical :: initialized = .false. logical :: preexisting_file = .false. logical :: data_mode = .false. + logical :: external_file_desc = .false. type (file_desc_t) :: pio_file character (len=StrKIND) :: filename integer :: iomode From 0b145f239cd54090bfba0c486017289ffaf6955d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 8 Aug 2019 17:32:32 -0600 Subject: [PATCH 018/331] Permit phase 2 bootstrapping from external PIO file_desc_t The mpas_bootstrap_framework_phase2 was previously capable of scanning through all input streams from the streams. file to find definitions of dimensions. With the changes in this commit, this search for dimensions can be restricted to a single, externally provided PIO file_desc_t. --- src/framework/mpas_bootstrapping.F | 210 +++++++++++++++++++---------- 1 file changed, 140 insertions(+), 70 deletions(-) diff --git a/src/framework/mpas_bootstrapping.F b/src/framework/mpas_bootstrapping.F index 6661620f35..1ec6265376 100644 --- a/src/framework/mpas_bootstrapping.F +++ b/src/framework/mpas_bootstrapping.F @@ -441,14 +441,16 @@ end subroutine mpas_bootstrap_framework_phase1 !}}} !> and allocating all fields and structs. ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase2(domain) !{{{ + subroutine mpas_bootstrap_framework_phase2(domain, pio_file_desc) !{{{ use mpas_stream_manager use mpas_stream_list + use pio, only : file_desc_t implicit none type (domain_type), pointer :: domain + type (file_desc_t), pointer, optional :: pio_file_desc type (mpas_pool_type), pointer :: readableDimensions type (mpas_pool_type), pointer :: streamDimensions @@ -478,105 +480,173 @@ subroutine mpas_bootstrap_framework_phase2(domain) !{{{ call mpas_log_write(' ') call mpas_log_write(' ') - ! Reading dimensions from streams - call mpas_log_write('Reading dimensions from input streams ...') - call mpas_stream_mgr_begin_iteration(domain % streamManager) - do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & - activeProperty = streamActive) ) + if (present(pio_file_desc)) then + call mpas_log_write('Reading dimensions from external PIO file handle ...') - if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) - call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) + call mpas_pool_begin_iteration(domain % blocklist % allFields) + do while ( mpas_pool_get_next_member(domain % blocklist % allFields, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_FIELD ) then + call get_dimlist_for_field(domain % blocklist % allFields, poolItr % memberName, dimNames) + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + end if + end do + end if + end do - ! Build stream dimension pool from the list of fields - call mpas_pool_create_pool(streamDimensions) + ioType = MPAS_IO_NETCDF ! ioType is not actually used when an external PIO file_desc_t is provided to MPAS_io_open + inputHandle = MPAS_io_open('FILENAME_NOT_USED', MPAS_IO_READ, ioType, domain % ioContext, pio_file_desc = pio_file_desc, ierr = err_local) - do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then - if (fieldActive) then - call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + call mpas_log_write(' ') + + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) - do i=1,size(dimNames) - call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) end if - end do - deallocate(dimNames) - end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + end if + end if end do - ! Determine stream filename - call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) + ! Close file + call MPAS_io_close(inputHandle) - ! Determine stream io_type - call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & - MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) + end if - ! Try to open file - inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) - ! If to determine if file was opened or not. - if ( err_local == MPAS_IO_NOERR ) then + else - call mpas_log_write(' ') - call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & - //trim(streamFilename) ) + ! Reading dimensions from streams + call mpas_log_write('Reading dimensions from input streams ...') + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & + activeProperty = streamActive) ) - ! Iterate over list of dimensions we determined we need from the above loop - call mpas_pool_begin_iteration(streamDimensions) - do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) - if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then - ! Try to read the dimension - call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then - ! Check to see if the dimension has already been defined - call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) - ! If to see if dimension was read or not - if ( err_local == MPAS_IO_NOERR ) then - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) + do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + + if (fieldActive) then + call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) - else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then - dimValue = tempDim - else if ( dimValue /= tempDim ) then - call mpas_log_write('Dimension ' // trim(poolItr % membername) & - // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) end if - else - call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') - end if - + end do + deallocate(dimNames) end if + end do - ! Close file - call mpas_io_close(inputHandle) - else - call mpas_log_write(' ') - call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & - //trim(streamName)//'''') - end if + ! Determine stream filename + call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) - ! Destroy pool that contains list of streams dimensions - call mpas_pool_destroy_pool(streamDimensions) + ! Determine stream io_type + call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & + MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) - else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + ! Try to open file + inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then + + call mpas_log_write(' ') + call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & + //trim(streamFilename) ) + + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + end if - call mpas_log_write(' ') - call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') + end if + end do + + ! Close file + call mpas_io_close(inputHandle) + else + call mpas_log_write(' ') + call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & + //trim(streamName)//'''') + end if + + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) + + else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + + call mpas_log_write(' ') + call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') - end if + end if - end do + end do - call mpas_log_write(' ') - call mpas_log_write('----- done reading dimensions from input streams -----') - call mpas_log_write(' ') - call mpas_log_write(' ') + call mpas_log_write(' ') + call mpas_log_write('----- done reading dimensions from input streams -----') + call mpas_log_write(' ') + call mpas_log_write(' ') + + end if call mpas_pool_set_error_level(err_level) From af7e0d30025c1412e2dd270829f64385e518748d Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Mon, 26 Aug 2019 15:16:34 -0600 Subject: [PATCH 019/331] Fix MPAS-A lw radation tendency Registry description This commit fixes a typo in the core_atmosphere's Registry.xml file by changes "short" to "long" in the var rthratenlw's description. --- src/core_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 591bfabdd2..c04e7c1109 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2824,7 +2824,7 @@ description="tendency of potential temperature due to short wave radiation"/> + description="tendency of potential temperature due to long wave radiation"/> From 9e4c369f549179e9df3ade2678d1c77f2684eba0 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Aug 2019 15:57:37 -0600 Subject: [PATCH 020/331] Permit creation of streams from existing PIO file descriptors This commit adds an optional argument, pio_file_desc, to the MPAS_createStream routine, enabling a stream to be created based on an existing, opened PIO file descriptor. The pio_file_desc argument is simply passed through to the MPAS_io_open routine. --- src/framework/mpas_io_streams.F | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/framework/mpas_io_streams.F b/src/framework/mpas_io_streams.F index a7e8b53937..2b703a47ab 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -78,7 +78,7 @@ module mpas_io_streams subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, precision, & - clobberRecords, clobberFiles, truncateFiles, ierr) + clobberRecords, clobberFiles, truncateFiles, pio_file_desc, ierr) implicit none @@ -91,6 +91,7 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, logical, intent(in), optional :: clobberRecords logical, intent(in), optional :: clobberFiles logical, intent(in), optional :: truncateFiles + type (file_desc_t), pointer, optional :: pio_file_desc integer, intent(out), optional :: ierr integer :: io_err @@ -99,7 +100,7 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, ioContext, clobber_file=clobberFiles, truncate_file=truncateFiles, & - ierr=io_err) + pio_file_desc=pio_file_desc, ierr=io_err) ! ! Catch a few special errors ! From d6e9f29ff90b13d987f8e7e3fdf5eed05600cae9 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 28 Aug 2019 16:43:57 -0600 Subject: [PATCH 021/331] src/core_init_atmosphere/mpas_init_atm_gwd.F: replicate logic from mpas_init_atm_static.F to handle config_geog_data_path with and without trailing slashes --- src/core_init_atmosphere/mpas_init_atm_gwd.F | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_gwd.F b/src/core_init_atmosphere/mpas_init_atm_gwd.F index 6d1632f9b2..fb51e89ec2 100644 --- a/src/core_init_atmosphere/mpas_init_atm_gwd.F +++ b/src/core_init_atmosphere/mpas_init_atm_gwd.F @@ -116,6 +116,7 @@ function compute_gwd_fields(domain) result(iErr) character(len=StrKIND), pointer :: config_geog_data_path character(len=StrKIND), pointer :: config_topo_data character(len=StrKIND) :: geog_sub_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash ! Variables for smoothing variance integer, dimension(:,:), pointer:: cellsOnCell @@ -134,6 +135,12 @@ function compute_gwd_fields(domain) result(iErr) call mpas_pool_get_config(domain % configs, 'config_topo_data', config_topo_data) call mpas_pool_get_config(domain % configs, 'config_gwd_cell_scaling', config_gwd_cell_scaling) + write(geog_data_path, '(a)') config_geog_data_path + i = len_trim(geog_data_path) + if (geog_data_path(i:i) /= '/') then + geog_data_path(i+1:i+1) = '/' + end if + select case(trim(config_topo_data)) case('GTOPO30') call mpas_log_write('--- Using GTOPO30 terrain dataset for GWDO static fields') @@ -188,13 +195,13 @@ function compute_gwd_fields(domain) result(iErr) allocate(hlanduse(nCells+1)) ! +1, since we access hlanduse(cellsOnCell(i,iCell)) later on for iCell=1,nCells - iErr = read_global_30s_topo(config_geog_data_path, geog_sub_path) + iErr = read_global_30s_topo(geog_data_path, geog_sub_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec topography for GWD statistics', messageType=MPAS_LOG_ERR) return end if - iErr = read_global_30s_landuse(config_geog_data_path) + iErr = read_global_30s_landuse(geog_data_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec landuse for GWD statistics', messageType=MPAS_LOG_ERR) return From 7153b52ec08463e56466d285137225ed4d89ba0e Mon Sep 17 00:00:00 2001 From: Miles A Curry Date: Tue, 23 Jul 2019 15:57:36 +0000 Subject: [PATCH 022/331] Fix and Update README Code Layout Section --- README.md | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index c29fec6914..6344d5c57c 100644 --- a/README.md +++ b/README.md @@ -43,14 +43,17 @@ only described below the src directory. MPAS-Model ├── src - │   ├── registry -- Code for building Registry.xml parser (Shared) │   ├── driver -- Main driver for MPAS in stand-alone mode (Shared) │   ├── external -- External software for MPAS (Shared) │   ├── framework -- MPAS Framework (Includes DDT Descriptions, and shared routines. Shared) │   ├── operators -- MPAS Opeartors (Includes Operators for MPAS meshes. Shared) - │   ├── inc -- Empty directory for include files that Registry generates (Shared) + │   ├── tools -- Empty directory for include files that Registry generates (Shared) + │   │  ├── registry -- Code for building Registry.xml parser (Shared) + │  │  └── input_gen -- Code for generating streams and namelist files (Shared) │   └── core_* -- Individual model cores. - └────── testing_and_setup -- tools for setting up configurations and tests cases (Shared) + │   └── inc -- Empty directory for include files that Registry generates + ├── testing_and_setup -- Tools for setting up configurations and test cases (Shared) + └── default_inputs -- Copies of default stream and namelists files (Shared) Model cores are typically developed independently. For information about building and running a particular core, please refer to that core's user's From 7ff78bb00a22dcb38e0f47e49df1b891deb44438 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 1 Nov 2019 07:49:22 -0600 Subject: [PATCH 023/331] Add cmake files to framework --- src/CMakeLists.txt | 136 ++++++++++++++++++++++++++++++++++++++++++ src/build_core.cmake | 106 ++++++++++++++++++++++++++++++++ src/cmake_utils.cmake | 74 +++++++++++++++++++++++ 3 files changed, 316 insertions(+) create mode 100644 src/CMakeLists.txt create mode 100644 src/build_core.cmake create mode 100644 src/cmake_utils.cmake diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000000..6d3b6a32ff --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,136 @@ +include(${CASEROOT}/Macros.cmake) + +# +# General setup +# + +if (USE_ESMF_LIB) + set(ESMFDIR "esmf") +else() + set(ESMFDIR "noesmf") +endif() + +set(CMAKE_C_COMPILER ${MPICC}) +set(CMAKE_CXX_COMPILER ${MPICXX}) +set(CMAKE_Fortran_COMPILER ${MPIFC}) +set(CMAKE_EXE_LINKER_FLAGS "${LDFLAGS}") +set(CMAKE_VERBOSE_MAKEFILE TRUE) + +# Set up CPPDEFS +set(FILE_OFFSET "-DOFFSET64BIT") +if (CPPDEFS) + separate_arguments(CPPDEFS UNIX_COMMAND "${CPPDEFS}") +endif() +list(APPEND CPPDEFS "-DMPAS_NO_LOG_REDIRECT" "-DUSE_PIO2" "-DMPAS_NO_ESMF_INIT" "-DMPAS_ESM_SHR_CONST" "-DMPAS_PERF_MOD_TIMERS" "${MODEL_FORMULATION}" "${FILE_OFFSET}" "${ZOLTAN_DEFINE}" "-D_MPI" "-DMPAS_NAMELIST_SUFFIX=${NAMELIST_SUFFIX}" "-DMPAS_EXE_NAME=${EXE_NAME}") +if (DEBUG) + list(APPEND CPPDEFS "-DMPAS_DEBUG") +endif() +if (compile_threaded) + list(APPEND CPPDEFS "-DMPAS_OPENMP") +endif() + +set(INCLUDES "${INSTALL_SHAREDPATH}/include" "${INSTALL_SHAREDPATH}/${COMP_INTERFACE}/${ESMFDIR}/${NINST_VALUE}/csm_share" "${INSTALL_SHAREDPATH}/pio" "${PNETCDF_PATH}/include" "${CMAKE_CURRENT_SOURCE_DIR}/external/ezxml" "${CMAKE_BINARY_DIR}/framework" "${CMAKE_BINARY_DIR}/operators") +if (NETCDF_PATH) + list(APPEND INCLUDES ${NETCDF_PATH}/include) +else() + if (NETCDF_C_PATH) + list(APPEND INCLUDES ${NETCDF_C_PATH}/include) + endif() + if (NETCDF_FORTRAN_PATH) + list(APPEND INCLUDES ${NETCDF_FORTRAN_PATH}/include) + endif() +endif() + +if (USE_KOKKOS) + include(${INSTALL_SHAREDPATH}/kokkos_generated_settings.cmake) + string (REPLACE ";" " " KOKKOS_CXXFLAGS_STR "${KOKKOS_CXXFLAGS}") + set(CXXFLAGS "${CXXFLAGS} ${KOKKOS_CXXFLAGS_STR}") +endif() + +set(CMAKE_Fortran_FLAGS "${FFLAGS}") +set(CMAKE_C_FLAGS "${CFLAGS}") +set(CMAKE_CXX_FLAGS "${CXXFLAGS}") + +# Make build tools +set(CMAKE_C_COMPILER ${SCC}) + +add_executable(streams_gen tools/input_gen/streams_gen.c tools/input_gen/test_functions.c external/ezxml/ezxml.c) +add_executable(namelist_gen tools/input_gen/namelist_gen.c tools/input_gen/test_functions.c external/ezxml/ezxml.c) +add_executable(parse tools/registry/parse.c tools/registry/dictionary.c tools/registry/gen_inc.c tools/registry/fortprintf.c tools/registry/utility.c external/ezxml/ezxml.c) + +foreach(EXEITEM streams_gen namelist_gen parse) + target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) + target_compile_options(${EXEITEM} PRIVATE "-Uvector") + target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) +endforeach() + +set(CMAKE_C_COMPILER ${MPICC}) + +# Gather sources that are needed for all cores + +# externals +set(COMMON_RAW_SOURCES external/ezxml/ezxml.c) + +# framework +list(APPEND COMMON_RAW_SOURCES + framework/mpas_kind_types.F + framework/mpas_framework.F + framework/mpas_timer.F + framework/mpas_timekeeping.F + framework/mpas_constants.F + framework/mpas_attlist.F + framework/mpas_hash.F + framework/mpas_sort.F + framework/mpas_block_decomp.F + framework/mpas_block_creator.F + framework/mpas_dmpar.F + framework/mpas_abort.F + framework/mpas_decomp.F + framework/mpas_threading.F + framework/mpas_io.F + framework/mpas_io_streams.F + framework/mpas_bootstrapping.F + framework/mpas_io_units.F + framework/mpas_stream_manager.F + framework/mpas_stream_list.F + framework/mpas_forcing.F + framework/mpas_c_interfacing.F + framework/random_id.c + framework/pool_hash.c + framework/mpas_derived_types.F + framework/mpas_domain_routines.F + framework/mpas_field_routines.F + framework/mpas_pool_routines.F + framework/xml_stream_parser.c + framework/regex_matching.c + framework/mpas_field_accessor.F + framework/mpas_log.F +) + +# operators +list(APPEND COMMON_RAW_SOURCES + operators/mpas_vector_operations.F + operators/mpas_matrix_operations.F + operators/mpas_tensor_operations.F + operators/mpas_rbf_interpolation.F + operators/mpas_vector_reconstruction.F + operators/mpas_spline_interpolation.F + operators/mpas_tracer_advection_helpers.F + operators/mpas_tracer_advection_mono.F + operators/mpas_tracer_advection_std.F + operators/mpas_geometry_utils.F +) + +include(${CMAKE_CURRENT_SOURCE_DIR}/cmake_utils.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/build_core.cmake) + +add_library(common OBJECT) +target_compile_definitions(common PRIVATE ${CPPDEFS}) +target_include_directories(common PRIVATE ${INCLUDES}) + +genf90_targets("${COMMON_RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "" "") +target_sources(common PRIVATE ${SOURCES}) + +foreach(CORE IN LISTS CORES) + build_core(${CORE}) +endforeach() diff --git a/src/build_core.cmake b/src/build_core.cmake new file mode 100644 index 0000000000..ab4ab4d67e --- /dev/null +++ b/src/build_core.cmake @@ -0,0 +1,106 @@ +function(build_core CORE) + set(EXE_NAME ${CORE}_model) + set(NAMELIST_SUFFIX ${CORE}) + + # Map the ESM component corresponding to each MPAS core + if (CORE STREQUAL "ocean") + set(COMPONENT "ocn") + elseif(CORE STREQUAL "landice") + set(COMPONENT "glc") + elseif(CORE STREQUAL "seaice") + set(COMPONENT "ice") + endif() + + # build_options.mk stuff handled here + if (CORE STREQUAL "ocean") + list(APPEND CPPDEFS "-DCORE_OCEAN") + list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_ocean/BGC" "${CMAKE_BINARY_DIR}/core_ocean/shared" "${CMAKE_BINARY_DIR}/core_ocean/analysis_members" "${CMAKE_BINARY_DIR}/core_ocean/cvmix" "${CMAKE_BINARY_DIR}/core_ocean/mode_forward" "${CMAKE_BINARY_DIR}/core_ocean/mode_analysis" "${CMAKE_BINARY_DIR}/core_ocean/mode_init") + + elseif (CORE STREQUAL "seaice") + list(APPEND CPPDEFS "-DCORE_SEAICE" "-Dcoupled" "-DCCSMCOUPLED") + list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_seaice/column" "${CMAKE_BINARY_DIR}/core_seaice/shared" "${CMAKE_BINARY_DIR}/core_seaice/analysis_members" "${CMAKE_BINARY_DIR}/core_seaice/model_forward") + + elseif (CORE STREQUAL "landice") + list(APPEND CPPDEFS "-DCORE_LANDICE") + list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_landice/shared" "${CMAKE_BINARY_DIR}/core_landice/analysis_members" "${CMAKE_BINARY_DIR}/core_landice/mode_forward") + + # + # Check if building with LifeV, Albany, and/or PHG external libraries + # + + if (LIFEV) + # LifeV can solve L1L2 or FO + list(APPEND CPPDEFS "-DLIFEV" "-DUSE_EXTERNAL_L1L2" "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") + endif() + + # Albany can only solve FO at present + if (ALBANY) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") + endif() + + if (LIFEV AND ALBANY) + message(FATAL "Compiling with both LifeV and Albany is not allowed at this time.") + endif() + + # PHG currently requires LifeV + if (PHG AND NOT LIFEV) + message(FATAL "Compiling with PHG requires LifeV at this time.") + endif() + + # PHG can only Stokes at present + if (PHG) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_STOKES" "-DMPAS_LI_BUILD_INTERFACE") + endif() + endif() + + add_library(${COMPONENT}) + target_compile_definitions(${COMPONENT} PRIVATE ${CPPDEFS}) + target_include_directories(${COMPONENT} PRIVATE ${INCLUDES}) + + # Gather sources + set(CORE_BLDDIR ${CMAKE_BINARY_DIR}/core_${CORE}) + if (NOT EXISTS ${CORE_BLDDIR}) + file(MAKE_DIRECTORY ${CORE_BLDDIR}) + endif() + + set(CORE_INPUT_DIR ${CORE_BLDDIR}/default_inputs) + if (NOT EXISTS ${CORE_INPUT_DIR}) + file(MAKE_DIRECTORY ${CORE_INPUT_DIR}) + endif() + + # Make .inc files + add_custom_command ( + OUTPUT ${CORE_BLDDIR}/Registry_processed.xml + COMMAND cpp -P -traditional ${CPPDEFS} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml > Registry_processed.xml + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml + WORKING_DIRECTORY ${CORE_BLDDIR} + ) + + set(INC_DIR ${CORE_BLDDIR}/inc) + if (NOT EXISTS ${INC_DIR}) + file(MAKE_DIRECTORY ${INC_DIR}) + endif() + + add_custom_command( + OUTPUT ${INC_DIR}/core_variables.inc + COMMAND ${CMAKE_BINARY_DIR}/mpas-source/src/parse < ${CORE_BLDDIR}/Registry_processed.xml + DEPENDS parse ${CORE_BLDDIR}/Registry_processed.xml + WORKING_DIRECTORY ${INC_DIR} + ) + + include(${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/${CORE}.cmake) + + # Disable qsmp for some files + if (FFLAGS MATCHES ".*-qsmp.*") + foreach(DISABLE_QSMP_FILE IN LISTS DISABLE_QSMP) + get_filename_component(SOURCE_EXT ${DISABLE_QSMP_FILE} EXT) + string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${DISABLE_QSMP_FILE}) + set_property(SOURCE ${CMAKE_BINARY_DIR}/${SOURCE_F90} APPEND_STRING PROPERTY COMPILE_FLAGS " -nosmp") + endforeach() + endif() + + genf90_targets("${RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "${NO_PREPROCESS}" "${INC_DIR}") + target_sources(${COMPONENT} PRIVATE ${SOURCES} $) + +endfunction(build_core) diff --git a/src/cmake_utils.cmake b/src/cmake_utils.cmake new file mode 100644 index 0000000000..0640abaad4 --- /dev/null +++ b/src/cmake_utils.cmake @@ -0,0 +1,74 @@ +# Function for handling nl and st gen +function(handle_st_nl_gen NL_GEN_ARGS ST_GEN_ARGS CORE_INPUT_DIR_ARG CORE_BLDDIR_ARG) + foreach(NL_GEN_ARG IN LISTS NL_GEN_ARGS) + separate_arguments(ITEMS UNIX_COMMAND "${NL_GEN_ARG}") + list(GET ITEMS 0 ITEM) + list(APPEND INPUTS ${ITEM}) + add_custom_command( + OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} + COMMAND ${CMAKE_BINARY_DIR}/namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${NL_GEN_ARG} + DEPENDS namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml + WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} + ) + endforeach() + + foreach(ST_GEN_ARG IN LISTS ST_GEN_ARGS) + separate_arguments(ITEMS UNIX_COMMAND "${ST_GEN_ARG}") + list(GET ITEMS 0 ITEM) + list(APPEND INPUTS ${ITEM}) + add_custom_command( + OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} + COMMAND ${CMAKE_BINARY_DIR}/streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${ST_GEN_ARG} + DEPENDS streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml + WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} + ) + endforeach() + + foreach(INPUT IN LISTS INPUTS) + add_custom_command( + OUTPUT ${CORE_BLDDIR_ARG}/${INPUT} + COMMAND ${CMAKE_COMMAND} -E copy ${CORE_INPUT_DIR_ARG}/${INPUT} ${CORE_BLDDIR_ARG}/${INPUT} + DEPENDS ${CORE_INPUT_DIR_ARG}/${INPUT} + WORKING_DIRECTORY ${CORE_BLDDIR_ARG} + ) + endforeach() +endfunction() + +# Function for generating f90 file targets, will add to parent's SOURCES var +function(genf90_targets RAW_SOURCES_ARG INCLUDES_ARG CPPDEFS_ARG NO_PREPROCESS_ARG CORE_INC_DIR_ARG) + # Add -I to includes so that they can used for cpp command + foreach(ITEM IN LISTS INCLUDES_ARG) + list(APPEND INCLUDES_I "-I${ITEM}") + endforeach() + + # Run all .F files through cpp to generate the f90 file + foreach(RAW_SOURCE_FILE IN LISTS RAW_SOURCES_ARG) + get_filename_component(SOURCE_EXT ${RAW_SOURCE_FILE} EXT) + if ( (SOURCE_EXT STREQUAL ".F" OR SOURCE_EXT STREQUAL ".F90") AND NOT RAW_SOURCE_FILE IN_LIST NO_PREPROCESS_ARG) + string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${RAW_SOURCE_FILE}) + get_filename_component(DIR_RELATIVE ${SOURCE_F90} DIRECTORY) + set(DIR_ABSOLUTE ${CMAKE_BINARY_DIR}/${DIR_RELATIVE}) + if (NOT EXISTS ${DIR_ABSOLUTE}) + file(MAKE_DIRECTORY ${DIR_ABSOLUTE}) + endif() + if (CORE_INC_DIR_ARG) + add_custom_command ( + OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} + COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90} + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} ${CORE_INC_DIR_ARG}/core_variables.inc) + else() + add_custom_command ( + OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} + COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90}) + endif() + list(APPEND LOCAL_SOURCES ${CMAKE_BINARY_DIR}/${SOURCE_F90}) + else() + list(APPEND LOCAL_SOURCES ${RAW_SOURCE_FILE}) + endif() + endforeach() + + set(SOURCES ${LOCAL_SOURCES} PARENT_SCOPE) + +endfunction(genf90_targets) From b45837870d262827d59b0bfeed45eaa0e2423ea9 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 1 Nov 2019 07:49:40 -0600 Subject: [PATCH 024/331] Add ocean cmake file --- src/core_ocean/ocean.cmake | 186 +++++++++++++++++++++++++++++++++++++ 1 file changed, 186 insertions(+) create mode 100644 src/core_ocean/ocean.cmake diff --git a/src/core_ocean/ocean.cmake b/src/core_ocean/ocean.cmake new file mode 100644 index 0000000000..d012b79006 --- /dev/null +++ b/src/core_ocean/ocean.cmake @@ -0,0 +1,186 @@ + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-ocean/driver/ocn_comp_mct.F + ../../mpas-ocean/driver/mpaso_cpl_indices.F + ../../mpas-ocean/driver/mpaso_mct_vars.F +) + +# dycore +list(APPEND RAW_SOURCES + core_ocean/mode_forward/mpas_ocn_forward_mode.F + core_ocean/mode_forward/mpas_ocn_time_integration.F + core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F + core_ocean/mode_forward/mpas_ocn_time_integration_split.F + + core_ocean/mode_analysis/mpas_ocn_analysis_mode.F + + core_ocean/mode_init/mpas_ocn_init_mode.F + core_ocean/mode_init/mpas_ocn_init_spherical_utils.F + core_ocean/mode_init/mpas_ocn_init_vertical_grids.F + core_ocean/mode_init/mpas_ocn_init_cell_markers.F + core_ocean/mode_init/mpas_ocn_init_interpolation.F + core_ocean/mode_init/mpas_ocn_init_ssh_and_landIcePressure.F + core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F + core_ocean/mode_init/mpas_ocn_init_lock_exchange.F + core_ocean/mode_init/mpas_ocn_init_dam_break.F + core_ocean/mode_init/mpas_ocn_init_internal_waves.F + core_ocean/mode_init/mpas_ocn_init_overflow.F + core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F + core_ocean/mode_init/mpas_ocn_init_iso.F + core_ocean/mode_init/mpas_ocn_init_soma.F + core_ocean/mode_init/mpas_ocn_init_ziso.F + core_ocean/mode_init/mpas_ocn_init_sub_ice_shelf_2D.F + core_ocean/mode_init/mpas_ocn_init_periodic_planar.F + core_ocean/mode_init/mpas_ocn_init_ecosys_column.F + core_ocean/mode_init/mpas_ocn_init_sea_mount.F + core_ocean/mode_init/mpas_ocn_init_global_ocean.F + core_ocean/mode_init/mpas_ocn_init_isomip.F + core_ocean/mode_init/mpas_ocn_init_hurricane.F + core_ocean/mode_init/mpas_ocn_init_isomip_plus.F + core_ocean/mode_init/mpas_ocn_init_tidal_boundary.F + + core_ocean/shared/mpas_ocn_init_routines.F + core_ocean/shared/mpas_ocn_gm.F + core_ocean/shared/mpas_ocn_diagnostics.F + core_ocean/shared/mpas_ocn_diagnostics_routines.F + core_ocean/shared/mpas_ocn_thick_ale.F + core_ocean/shared/mpas_ocn_equation_of_state.F + core_ocean/shared/mpas_ocn_equation_of_state_jm.F + core_ocean/shared/mpas_ocn_equation_of_state_linear.F + core_ocean/shared/mpas_ocn_thick_hadv.F + core_ocean/shared/mpas_ocn_thick_vadv.F + core_ocean/shared/mpas_ocn_thick_surface_flux.F + core_ocean/shared/mpas_ocn_vel_hadv_coriolis.F + core_ocean/shared/mpas_ocn_vel_vadv.F + core_ocean/shared/mpas_ocn_vel_hmix.F + core_ocean/shared/mpas_ocn_vel_hmix_del2.F + core_ocean/shared/mpas_ocn_vel_hmix_leith.F + core_ocean/shared/mpas_ocn_vel_hmix_del4.F + core_ocean/shared/mpas_ocn_vel_forcing.F + core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F + core_ocean/shared/mpas_ocn_vel_forcing_explicit_bottom_drag.F + core_ocean/shared/mpas_ocn_vel_pressure_grad.F + core_ocean/shared/mpas_ocn_vmix.F + core_ocean/shared/mpas_ocn_vmix_coefs_const.F + core_ocean/shared/mpas_ocn_vmix_coefs_rich.F + core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F + core_ocean/shared/mpas_ocn_vmix_coefs_redi.F + core_ocean/shared/mpas_ocn_vmix_cvmix.F + core_ocean/shared/mpas_ocn_tendency.F + core_ocean/shared/mpas_ocn_tracer_hmix.F + core_ocean/shared/mpas_ocn_tracer_hmix_del2.F + core_ocean/shared/mpas_ocn_tracer_hmix_del4.F + core_ocean/shared/mpas_ocn_tracer_hmix_redi.F + core_ocean/shared/mpas_ocn_tracer_advection.F + core_ocean/shared/mpas_ocn_tracer_advection_mono.F + core_ocean/shared/mpas_ocn_tracer_advection_std.F + core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_variable.F + core_ocean/shared/mpas_ocn_tracer_surface_restoring.F + core_ocean/shared/mpas_ocn_tracer_interior_restoring.F + core_ocean/shared/mpas_ocn_tracer_exponential_decay.F + core_ocean/shared/mpas_ocn_tracer_ideal_age.F + core_ocean/shared/mpas_ocn_tracer_TTD.F + core_ocean/shared/mpas_ocn_tracer_ecosys.F + core_ocean/shared/mpas_ocn_tracer_DMS.F + core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F + core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F + core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F + core_ocean/shared/mpas_ocn_test.F + core_ocean/shared/mpas_ocn_constants.F + core_ocean/shared/mpas_ocn_forcing.F + core_ocean/shared/mpas_ocn_surface_bulk_forcing.F + core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F + core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F + core_ocean/shared/mpas_ocn_frazil_forcing.F + core_ocean/shared/mpas_ocn_tidal_forcing.F + core_ocean/shared/mpas_ocn_time_average_coupled.F + core_ocean/shared/mpas_ocn_sea_ice.F + core_ocean/shared/mpas_ocn_framework_forcing.F + core_ocean/shared/mpas_ocn_time_varying_forcing.F + core_ocean/shared/mpas_ocn_wetting_drying.F + core_ocean/shared/mpas_ocn_tidal_potential_forcing.F +) + +set(OCEAN_DRIVER + core_ocean/driver/mpas_ocn_core.F + core_ocean/driver/mpas_ocn_core_interface.F +) +list(APPEND RAW_SOURCES ${OCEAN_DRIVER}) +list(APPEND DISABLE_QSMP ${OCEAN_DRIVER}) + +# Get CVMix +execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_cvmix.sh + WORKING_DIRECTORY ${CORE_BLDDIR}) + +# Get BGC +execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_BGC.sh + WORKING_DIRECTORY ${CORE_BLDDIR}) + +# Add CVMix +set(CVMIX_FILES + ${CORE_BLDDIR}/cvmix/cvmix_kinds_and_types.F90 + ${CORE_BLDDIR}/cvmix/cvmix_background.F90 + ${CORE_BLDDIR}/cvmix/cvmix_convection.F90 + ${CORE_BLDDIR}/cvmix/cvmix_ddiff.F90 + ${CORE_BLDDIR}/cvmix/cvmix_kpp.F90 + ${CORE_BLDDIR}/cvmix/cvmix_math.F90 + ${CORE_BLDDIR}/cvmix/cvmix_put_get.F90 + ${CORE_BLDDIR}/cvmix/cvmix_shear.F90 + ${CORE_BLDDIR}/cvmix/cvmix_tidal.F90 + ${CORE_BLDDIR}/cvmix/cvmix_utils.F90 +) + +# Add BGC +set(BGC_FILES + ${CORE_BLDDIR}/BGC/BGC_mod.F90 + ${CORE_BLDDIR}/BGC/BGC_parms.F90 + ${CORE_BLDDIR}/BGC/DMS_mod.F90 + ${CORE_BLDDIR}/BGC/DMS_parms.F90 + ${CORE_BLDDIR}/BGC/MACROS_mod.F90 + ${CORE_BLDDIR}/BGC/MACROS_parms.F90 + ${CORE_BLDDIR}/BGC/co2calc.F90 +) + +list(APPEND RAW_SOURCES ${CVMIX_FILES} ${BGC_FILES}) +list(APPEND NO_PREPROCESS ${CVMIX_FILES} ${BGC_FILES}) + +# Add analysis members +list(APPEND RAW_SOURCES + core_ocean/analysis_members/mpas_ocn_global_stats.F + core_ocean/analysis_members/mpas_ocn_okubo_weiss.F + core_ocean/analysis_members/mpas_ocn_okubo_weiss_eigenvalues.c + core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F + core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F + core_ocean/analysis_members/mpas_ocn_water_mass_census.F + core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F + core_ocean/analysis_members/mpas_ocn_test_compute_interval.F + core_ocean/analysis_members/mpas_ocn_high_frequency_output.F + core_ocean/analysis_members/mpas_ocn_zonal_mean.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F + core_ocean/analysis_members/mpas_ocn_particle_list.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F + core_ocean/analysis_members/mpas_ocn_eliassen_palm.F + core_ocean/analysis_members/mpas_ocn_time_filters.F + core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F + core_ocean/analysis_members/mpas_ocn_pointwise_stats.F + core_ocean/analysis_members/mpas_ocn_debug_diagnostics.F + core_ocean/analysis_members/mpas_ocn_time_series_stats.F + core_ocean/analysis_members/mpas_ocn_regional_stats.F + core_ocean/analysis_members/mpas_ocn_rpn_calculator.F + core_ocean/analysis_members/mpas_ocn_transect_transport.F + core_ocean/analysis_members/mpas_ocn_eddy_product_variables.F + core_ocean/analysis_members/mpas_ocn_moc_streamfunction.F + core_ocean/analysis_members/mpas_ocn_analysis_driver.F +) + +# Generate core input +handle_st_nl_gen( + "namelist.ocean;namelist.ocean.forward mode=forward;namelist.ocean.analysis mode=analysis;namelist.ocean.init mode=init" + "streams.ocean stream_list.ocean. mutable;streams.ocean.forward stream_list.ocean.forward. mutable mode=forward;streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis;streams.ocean.init stream_list.ocean.init. mutable mode=init" + ${CORE_INPUT_DIR} ${CORE_BLDDIR} +) From 4f760e710e4613cc9916d0b704e5100fb870baba Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 1 Nov 2019 07:49:50 -0600 Subject: [PATCH 025/331] Add seaice cmake file --- src/core_seaice/seaice.cmake | 103 +++++++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) create mode 100644 src/core_seaice/seaice.cmake diff --git a/src/core_seaice/seaice.cmake b/src/core_seaice/seaice.cmake new file mode 100644 index 0000000000..fa3e01ca0e --- /dev/null +++ b/src/core_seaice/seaice.cmake @@ -0,0 +1,103 @@ + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-seaice/driver/ice_comp_mct.F + ../../mpas-seaice/driver/mpassi_cpl_indices.F + ../../mpas-seaice/driver/mpassi_mct_vars.F +) + +# column +list(APPEND RAW_SOURCES + core_seaice/column/ice_colpkg.F90 + core_seaice/column/ice_kinds_mod.F90 + core_seaice/column/ice_warnings.F90 + core_seaice/column/ice_colpkg_shared.F90 + core_seaice/column/constants/cesm/ice_constants_colpkg.F90 + core_seaice/column/ice_therm_shared.F90 + core_seaice/column/ice_orbital.F90 + core_seaice/column/ice_mushy_physics.F90 + core_seaice/column/ice_therm_mushy.F90 + core_seaice/column/ice_atmo.F90 + core_seaice/column/ice_age.F90 + core_seaice/column/ice_firstyear.F90 + core_seaice/column/ice_flux_colpkg.F90 + core_seaice/column/ice_meltpond_cesm.F90 + core_seaice/column/ice_meltpond_lvl.F90 + core_seaice/column/ice_meltpond_topo.F90 + core_seaice/column/ice_therm_vertical.F90 + core_seaice/column/ice_therm_bl99.F90 + core_seaice/column/ice_therm_0layer.F90 + core_seaice/column/ice_itd.F90 + core_seaice/column/ice_colpkg_tracers.F90 + core_seaice/column/ice_therm_itd.F90 + core_seaice/column/ice_shortwave.F90 + core_seaice/column/ice_mechred.F90 + core_seaice/column/ice_aerosol.F90 + core_seaice/column/ice_brine.F90 + core_seaice/column/ice_algae.F90 + core_seaice/column/ice_zbgc.F90 + core_seaice/column/ice_zbgc_shared.F90 + core_seaice/column/ice_zsalinity.F90 + core_seaice/column/ice_snow.F90 +) + +# shared +list(APPEND RAW_SOURCES + core_seaice/shared/mpas_seaice_time_integration.F + core_seaice/shared/mpas_seaice_advection_incremental_remap_tracers.F + core_seaice/shared/mpas_seaice_advection_incremental_remap.F + core_seaice/shared/mpas_seaice_advection_upwind.F + core_seaice/shared/mpas_seaice_advection.F + core_seaice/shared/mpas_seaice_velocity_solver_unit_tests.F + core_seaice/shared/mpas_seaice_velocity_solver.F + core_seaice/shared/mpas_seaice_velocity_solver_weak.F + core_seaice/shared/mpas_seaice_velocity_solver_variational.F + core_seaice/shared/mpas_seaice_velocity_solver_wachspress.F + core_seaice/shared/mpas_seaice_velocity_solver_pwl.F + core_seaice/shared/mpas_seaice_velocity_solver_variational_shared.F + core_seaice/shared/mpas_seaice_velocity_solver_constitutive_relation.F + core_seaice/shared/mpas_seaice_forcing.F + core_seaice/shared/mpas_seaice_initialize.F + core_seaice/shared/mpas_seaice_testing.F + core_seaice/shared/mpas_seaice_unit_test.F + core_seaice/shared/mpas_seaice_mesh.F + core_seaice/shared/mpas_seaice_diagnostics.F + core_seaice/shared/mpas_seaice_numerics.F + core_seaice/shared/mpas_seaice_constants.F + core_seaice/shared/mpas_seaice_column.F + core_seaice/shared/mpas_seaice_diagnostics.F + core_seaice/shared/mpas_seaice_error.F +) + +# analysis members +list(APPEND RAW_SOURCES + core_seaice/analysis_members/mpas_seaice_analysis_driver.F + core_seaice/analysis_members/mpas_seaice_high_frequency_output.F + core_seaice/analysis_members/mpas_seaice_temperatures.F + core_seaice/analysis_members/mpas_seaice_regional_statistics.F + core_seaice/analysis_members/mpas_seaice_ridging_diagnostics.F + core_seaice/analysis_members/mpas_seaice_conservation_check.F + core_seaice/analysis_members/mpas_seaice_geographical_vectors.F + core_seaice/analysis_members/mpas_seaice_ice_present.F + core_seaice/analysis_members/mpas_seaice_time_series_stats.F + core_seaice/analysis_members/mpas_seaice_load_balance.F + core_seaice/analysis_members/mpas_seaice_maximum_ice_presence.F + core_seaice/analysis_members/mpas_seaice_miscellaneous.F + core_seaice/analysis_members/mpas_seaice_area_variables.F + core_seaice/analysis_members/mpas_seaice_pond_diagnostics.F + core_seaice/analysis_members/mpas_seaice_deactivate_unneeded_fields.F + core_seaice/analysis_members/mpas_seaice_pointwise_stats.F + core_seaice/analysis_members/mpas_seaice_unit_conversion.F + core_seaice/analysis_members/mpas_seaice_ice_shelves.F +) + +# model_forward (DISABLE qsmp for these) +set(SEAICE_MODEL_FORWARD + core_seaice/model_forward/mpas_seaice_core.F + core_seaice/model_forward/mpas_seaice_core_interface.F +) +list(APPEND RAW_SOURCES ${SEAICE_MODEL_FORWARD}) +list(APPEND DISABLE_QSMP ${SEAICE_MODEL_FORWARD}) + +# Generate core input +handle_st_nl_gen("namelist.seaice" "streams.seaice stream_list.seaice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) From 8271b0b5bf0165ff9922fa4256620ad70864dbf5 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 1 Nov 2019 07:50:04 -0600 Subject: [PATCH 026/331] Add landice cmake file --- src/core_landice/landice.cmake | 47 ++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 src/core_landice/landice.cmake diff --git a/src/core_landice/landice.cmake b/src/core_landice/landice.cmake new file mode 100644 index 0000000000..e28fa92753 --- /dev/null +++ b/src/core_landice/landice.cmake @@ -0,0 +1,47 @@ + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-albany-landice/driver/glc_comp_mct.F + ../../mpas-albany-landice/driver/glc_cpl_indices.F + ../../mpas-albany-landice/driver/glc_mct_vars.F +) + +# shared +list(APPEND RAW_SOURCES + core_landice/shared/mpas_li_constants.F + core_landice/shared/mpas_li_mask.F + core_landice/shared/mpas_li_setup.F +) + +# analysis members +list(APPEND RAW_SOURCES + core_landice/analysis_members/mpas_li_analysis_driver.F + core_landice/analysis_members/mpas_li_global_stats.F + core_landice/analysis_members/mpas_li_regional_stats.F +) + +# mode forward +list(APPEND RAW_SOURCES + core_landice/mode_forward/mpas_li_core.F + core_landice/mode_forward/mpas_li_core_interface.F + core_landice/mode_forward/mpas_li_time_integration.F + core_landice/mode_forward/mpas_li_time_integration_fe.F + core_landice/mode_forward/mpas_li_diagnostic_vars.F + core_landice/mode_forward/mpas_li_advection.F + core_landice/mode_forward/mpas_li_calving.F + core_landice/mode_forward/mpas_li_statistics.F + core_landice/mode_forward/mpas_li_velocity.F + core_landice/mode_forward/mpas_li_thermal.F + core_landice/mode_forward/mpas_li_iceshelf_melt.F + core_landice/mode_forward/mpas_li_sia.F + core_landice/mode_forward/mpas_li_velocity_simple.F + core_landice/mode_forward/mpas_li_velocity_external.F + core_landice/mode_forward/mpas_li_subglacial_hydro.F +) + +if (CPPFLAGS MATCHES ".*MPAS_LI_BUILD_INTERFACE.*") + list(APPEND RAW_SOURCES core_landice/mode_forward/Interface_velocity_solver.cpp) +endif() + +# Generate core input +handle_st_nl_gen("namelist.landice" "streams.landice stream_list.landice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) From fd99516bf4deb6738563e96ce5af2a3a55a20535 Mon Sep 17 00:00:00 2001 From: James Foucar Date: Mon, 4 Nov 2019 16:28:15 -0700 Subject: [PATCH 027/331] Add tools as a subdirectory so that it can use serial compiler --- src/CMakeLists.txt | 15 +-------------- src/build_core.cmake | 2 +- src/cmake_utils.cmake | 4 ++-- src/tools/CMakeLists.txt | 13 +++++++++++++ 4 files changed, 17 insertions(+), 17 deletions(-) create mode 100644 src/tools/CMakeLists.txt diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 6d3b6a32ff..514b2e686f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -51,20 +51,7 @@ set(CMAKE_Fortran_FLAGS "${FFLAGS}") set(CMAKE_C_FLAGS "${CFLAGS}") set(CMAKE_CXX_FLAGS "${CXXFLAGS}") -# Make build tools -set(CMAKE_C_COMPILER ${SCC}) - -add_executable(streams_gen tools/input_gen/streams_gen.c tools/input_gen/test_functions.c external/ezxml/ezxml.c) -add_executable(namelist_gen tools/input_gen/namelist_gen.c tools/input_gen/test_functions.c external/ezxml/ezxml.c) -add_executable(parse tools/registry/parse.c tools/registry/dictionary.c tools/registry/gen_inc.c tools/registry/fortprintf.c tools/registry/utility.c external/ezxml/ezxml.c) - -foreach(EXEITEM streams_gen namelist_gen parse) - target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) - target_compile_options(${EXEITEM} PRIVATE "-Uvector") - target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) -endforeach() - -set(CMAKE_C_COMPILER ${MPICC}) +add_subdirectory(tools) # Gather sources that are needed for all cores diff --git a/src/build_core.cmake b/src/build_core.cmake index ab4ab4d67e..8019fdfa37 100644 --- a/src/build_core.cmake +++ b/src/build_core.cmake @@ -84,7 +84,7 @@ function(build_core CORE) add_custom_command( OUTPUT ${INC_DIR}/core_variables.inc - COMMAND ${CMAKE_BINARY_DIR}/mpas-source/src/parse < ${CORE_BLDDIR}/Registry_processed.xml + COMMAND ${CMAKE_BINARY_DIR}/mpas-source/src/tools/parse < ${CORE_BLDDIR}/Registry_processed.xml DEPENDS parse ${CORE_BLDDIR}/Registry_processed.xml WORKING_DIRECTORY ${INC_DIR} ) diff --git a/src/cmake_utils.cmake b/src/cmake_utils.cmake index 0640abaad4..c3a25f238d 100644 --- a/src/cmake_utils.cmake +++ b/src/cmake_utils.cmake @@ -6,7 +6,7 @@ function(handle_st_nl_gen NL_GEN_ARGS ST_GEN_ARGS CORE_INPUT_DIR_ARG CORE_BLDDIR list(APPEND INPUTS ${ITEM}) add_custom_command( OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} - COMMAND ${CMAKE_BINARY_DIR}/namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${NL_GEN_ARG} + COMMAND ${CMAKE_BINARY_DIR}/tools/namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${NL_GEN_ARG} DEPENDS namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} ) @@ -18,7 +18,7 @@ function(handle_st_nl_gen NL_GEN_ARGS ST_GEN_ARGS CORE_INPUT_DIR_ARG CORE_BLDDIR list(APPEND INPUTS ${ITEM}) add_custom_command( OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} - COMMAND ${CMAKE_BINARY_DIR}/streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${ST_GEN_ARG} + COMMAND ${CMAKE_BINARY_DIR}/tools/streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${ST_GEN_ARG} DEPENDS streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} ) diff --git a/src/tools/CMakeLists.txt b/src/tools/CMakeLists.txt new file mode 100644 index 0000000000..a8bae570bc --- /dev/null +++ b/src/tools/CMakeLists.txt @@ -0,0 +1,13 @@ + +# Make build tools, need to be compiled with serial compiler. +set(CMAKE_C_COMPILER ${SCC}) + +add_executable(streams_gen input_gen/streams_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) +add_executable(namelist_gen input_gen/namelist_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) +add_executable(parse registry/parse.c registry/dictionary.c registry/gen_inc.c registry/fortprintf.c registry/utility.c ../external/ezxml/ezxml.c) + +foreach(EXEITEM streams_gen namelist_gen parse) + target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) + target_compile_options(${EXEITEM} PRIVATE "-Uvector") + target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) +endforeach() From bcf58251dab87bdd85acd6b8c809d28afb7026cf Mon Sep 17 00:00:00 2001 From: James Foucar Date: Wed, 6 Nov 2019 10:22:40 -0700 Subject: [PATCH 028/331] Improve docs, put core-specific stuff in core.cmake --- src/CMakeLists.txt | 74 +++++++++------------------------- src/build_core.cmake | 57 +++++--------------------- src/core_landice/landice.cmake | 32 +++++++++++++++ src/core_ocean/ocean.cmake | 4 ++ src/core_seaice/seaice.cmake | 5 +++ src/framework/framework.cmake | 35 ++++++++++++++++ src/operators/operators.cmake | 13 ++++++ 7 files changed, 117 insertions(+), 103 deletions(-) create mode 100644 src/framework/framework.cmake create mode 100644 src/operators/operators.cmake diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 514b2e686f..0f9a19e866 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,3 +1,13 @@ +# +# This is the interface between E3SM's new CMake-based build system and MPAS. +# +# The following CMake variables are expected to be defined: +# * CORES : A list of CORES to build, comma-separated (e.g. "ocean,seaice,landice") +# * Whatever CIME settings are setting to correctly resolve the ${CASEROOT}/Macros.cmake file +# - COMPILER, DEBUG, MPILIB, MACH, OS +# + +# Source CIME-generated Macros include(${CASEROOT}/Macros.cmake) # @@ -51,65 +61,18 @@ set(CMAKE_Fortran_FLAGS "${FFLAGS}") set(CMAKE_C_FLAGS "${CFLAGS}") set(CMAKE_CXX_FLAGS "${CXXFLAGS}") +# Include custom cmake libraries used for mpas +include(${CMAKE_CURRENT_SOURCE_DIR}/cmake_utils.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/build_core.cmake) + +# Add tools add_subdirectory(tools) -# Gather sources that are needed for all cores +# Gather sources that are needed for all cores into "common" library -# externals set(COMMON_RAW_SOURCES external/ezxml/ezxml.c) - -# framework -list(APPEND COMMON_RAW_SOURCES - framework/mpas_kind_types.F - framework/mpas_framework.F - framework/mpas_timer.F - framework/mpas_timekeeping.F - framework/mpas_constants.F - framework/mpas_attlist.F - framework/mpas_hash.F - framework/mpas_sort.F - framework/mpas_block_decomp.F - framework/mpas_block_creator.F - framework/mpas_dmpar.F - framework/mpas_abort.F - framework/mpas_decomp.F - framework/mpas_threading.F - framework/mpas_io.F - framework/mpas_io_streams.F - framework/mpas_bootstrapping.F - framework/mpas_io_units.F - framework/mpas_stream_manager.F - framework/mpas_stream_list.F - framework/mpas_forcing.F - framework/mpas_c_interfacing.F - framework/random_id.c - framework/pool_hash.c - framework/mpas_derived_types.F - framework/mpas_domain_routines.F - framework/mpas_field_routines.F - framework/mpas_pool_routines.F - framework/xml_stream_parser.c - framework/regex_matching.c - framework/mpas_field_accessor.F - framework/mpas_log.F -) - -# operators -list(APPEND COMMON_RAW_SOURCES - operators/mpas_vector_operations.F - operators/mpas_matrix_operations.F - operators/mpas_tensor_operations.F - operators/mpas_rbf_interpolation.F - operators/mpas_vector_reconstruction.F - operators/mpas_spline_interpolation.F - operators/mpas_tracer_advection_helpers.F - operators/mpas_tracer_advection_mono.F - operators/mpas_tracer_advection_std.F - operators/mpas_geometry_utils.F -) - -include(${CMAKE_CURRENT_SOURCE_DIR}/cmake_utils.cmake) -include(${CMAKE_CURRENT_SOURCE_DIR}/build_core.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/framework/framework.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/operators/operators.cmake) add_library(common OBJECT) target_compile_definitions(common PRIVATE ${CPPDEFS}) @@ -118,6 +81,7 @@ target_include_directories(common PRIVATE ${INCLUDES}) genf90_targets("${COMMON_RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "" "") target_sources(common PRIVATE ${SOURCES}) +# Build cores! foreach(CORE IN LISTS CORES) build_core(${CORE}) endforeach() diff --git a/src/build_core.cmake b/src/build_core.cmake index 8019fdfa37..b91904b55d 100644 --- a/src/build_core.cmake +++ b/src/build_core.cmake @@ -9,54 +9,10 @@ function(build_core CORE) set(COMPONENT "glc") elseif(CORE STREQUAL "seaice") set(COMPONENT "ice") + else() + message(FATAL_ERROR "Unrecognized core: ${CORE}") endif() - # build_options.mk stuff handled here - if (CORE STREQUAL "ocean") - list(APPEND CPPDEFS "-DCORE_OCEAN") - list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_ocean/BGC" "${CMAKE_BINARY_DIR}/core_ocean/shared" "${CMAKE_BINARY_DIR}/core_ocean/analysis_members" "${CMAKE_BINARY_DIR}/core_ocean/cvmix" "${CMAKE_BINARY_DIR}/core_ocean/mode_forward" "${CMAKE_BINARY_DIR}/core_ocean/mode_analysis" "${CMAKE_BINARY_DIR}/core_ocean/mode_init") - - elseif (CORE STREQUAL "seaice") - list(APPEND CPPDEFS "-DCORE_SEAICE" "-Dcoupled" "-DCCSMCOUPLED") - list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_seaice/column" "${CMAKE_BINARY_DIR}/core_seaice/shared" "${CMAKE_BINARY_DIR}/core_seaice/analysis_members" "${CMAKE_BINARY_DIR}/core_seaice/model_forward") - - elseif (CORE STREQUAL "landice") - list(APPEND CPPDEFS "-DCORE_LANDICE") - list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_landice/shared" "${CMAKE_BINARY_DIR}/core_landice/analysis_members" "${CMAKE_BINARY_DIR}/core_landice/mode_forward") - - # - # Check if building with LifeV, Albany, and/or PHG external libraries - # - - if (LIFEV) - # LifeV can solve L1L2 or FO - list(APPEND CPPDEFS "-DLIFEV" "-DUSE_EXTERNAL_L1L2" "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") - endif() - - # Albany can only solve FO at present - if (ALBANY) - list(APPEND CPPDEFS "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") - endif() - - if (LIFEV AND ALBANY) - message(FATAL "Compiling with both LifeV and Albany is not allowed at this time.") - endif() - - # PHG currently requires LifeV - if (PHG AND NOT LIFEV) - message(FATAL "Compiling with PHG requires LifeV at this time.") - endif() - - # PHG can only Stokes at present - if (PHG) - list(APPEND CPPDEFS "-DUSE_EXTERNAL_STOKES" "-DMPAS_LI_BUILD_INTERFACE") - endif() - endif() - - add_library(${COMPONENT}) - target_compile_definitions(${COMPONENT} PRIVATE ${CPPDEFS}) - target_include_directories(${COMPONENT} PRIVATE ${INCLUDES}) - # Gather sources set(CORE_BLDDIR ${CMAKE_BINARY_DIR}/core_${CORE}) if (NOT EXISTS ${CORE_BLDDIR}) @@ -68,6 +24,13 @@ function(build_core CORE) file(MAKE_DIRECTORY ${CORE_INPUT_DIR}) endif() + # Provides us RAW_SOURCES, CPPDEFS, and INCLUDES + include(${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/${CORE}.cmake) + + add_library(${COMPONENT}) + target_compile_definitions(${COMPONENT} PRIVATE ${CPPDEFS}) + target_include_directories(${COMPONENT} PRIVATE ${INCLUDES}) + # Make .inc files add_custom_command ( OUTPUT ${CORE_BLDDIR}/Registry_processed.xml @@ -89,8 +52,6 @@ function(build_core CORE) WORKING_DIRECTORY ${INC_DIR} ) - include(${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/${CORE}.cmake) - # Disable qsmp for some files if (FFLAGS MATCHES ".*-qsmp.*") foreach(DISABLE_QSMP_FILE IN LISTS DISABLE_QSMP) diff --git a/src/core_landice/landice.cmake b/src/core_landice/landice.cmake index e28fa92753..232f3ccc9d 100644 --- a/src/core_landice/landice.cmake +++ b/src/core_landice/landice.cmake @@ -1,4 +1,36 @@ +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_LANDICE") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_landice/shared" "${CMAKE_BINARY_DIR}/core_landice/analysis_members" "${CMAKE_BINARY_DIR}/core_landice/mode_forward") + +# +# Check if building with LifeV, Albany, and/or PHG external libraries +# + +if (LIFEV) + # LifeV can solve L1L2 or FO + list(APPEND CPPDEFS "-DLIFEV" "-DUSE_EXTERNAL_L1L2" "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") +endif() + +# Albany can only solve FO at present +if (ALBANY) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") +endif() + +if (LIFEV AND ALBANY) + message(FATAL "Compiling with both LifeV and Albany is not allowed at this time.") +endif() + +# PHG currently requires LifeV +if (PHG AND NOT LIFEV) + message(FATAL "Compiling with PHG requires LifeV at this time.") +endif() + +# PHG can only Stokes at present +if (PHG) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_STOKES" "-DMPAS_LI_BUILD_INTERFACE") +endif() + # driver (files live in E3SM) list(APPEND RAW_SOURCES ../../mpas-albany-landice/driver/glc_comp_mct.F diff --git a/src/core_ocean/ocean.cmake b/src/core_ocean/ocean.cmake index d012b79006..29679934d2 100644 --- a/src/core_ocean/ocean.cmake +++ b/src/core_ocean/ocean.cmake @@ -1,4 +1,8 @@ +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_OCEAN") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_ocean/BGC" "${CMAKE_BINARY_DIR}/core_ocean/shared" "${CMAKE_BINARY_DIR}/core_ocean/analysis_members" "${CMAKE_BINARY_DIR}/core_ocean/cvmix" "${CMAKE_BINARY_DIR}/core_ocean/mode_forward" "${CMAKE_BINARY_DIR}/core_ocean/mode_analysis" "${CMAKE_BINARY_DIR}/core_ocean/mode_init") + # driver (files live in E3SM) list(APPEND RAW_SOURCES ../../mpas-ocean/driver/ocn_comp_mct.F diff --git a/src/core_seaice/seaice.cmake b/src/core_seaice/seaice.cmake index fa3e01ca0e..0ac2b0dd49 100644 --- a/src/core_seaice/seaice.cmake +++ b/src/core_seaice/seaice.cmake @@ -1,4 +1,9 @@ +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_SEAICE" "-Dcoupled" "-DCCSMCOUPLED") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_seaice/column" "${CMAKE_BINARY_DIR}/core_seaice/shared" "${CMAKE_BINARY_DIR}/core_seaice/analysis_members" "${CMAKE_BINARY_DIR}/core_seaice/model_forward") + + # driver (files live in E3SM) list(APPEND RAW_SOURCES ../../mpas-seaice/driver/ice_comp_mct.F diff --git a/src/framework/framework.cmake b/src/framework/framework.cmake new file mode 100644 index 0000000000..f74747fb4f --- /dev/null +++ b/src/framework/framework.cmake @@ -0,0 +1,35 @@ +# framework +list(APPEND COMMON_RAW_SOURCES + framework/mpas_kind_types.F + framework/mpas_framework.F + framework/mpas_timer.F + framework/mpas_timekeeping.F + framework/mpas_constants.F + framework/mpas_attlist.F + framework/mpas_hash.F + framework/mpas_sort.F + framework/mpas_block_decomp.F + framework/mpas_block_creator.F + framework/mpas_dmpar.F + framework/mpas_abort.F + framework/mpas_decomp.F + framework/mpas_threading.F + framework/mpas_io.F + framework/mpas_io_streams.F + framework/mpas_bootstrapping.F + framework/mpas_io_units.F + framework/mpas_stream_manager.F + framework/mpas_stream_list.F + framework/mpas_forcing.F + framework/mpas_c_interfacing.F + framework/random_id.c + framework/pool_hash.c + framework/mpas_derived_types.F + framework/mpas_domain_routines.F + framework/mpas_field_routines.F + framework/mpas_pool_routines.F + framework/xml_stream_parser.c + framework/regex_matching.c + framework/mpas_field_accessor.F + framework/mpas_log.F +) diff --git a/src/operators/operators.cmake b/src/operators/operators.cmake new file mode 100644 index 0000000000..d65c7c661e --- /dev/null +++ b/src/operators/operators.cmake @@ -0,0 +1,13 @@ +# operators +list(APPEND COMMON_RAW_SOURCES + operators/mpas_vector_operations.F + operators/mpas_matrix_operations.F + operators/mpas_tensor_operations.F + operators/mpas_rbf_interpolation.F + operators/mpas_vector_reconstruction.F + operators/mpas_spline_interpolation.F + operators/mpas_tracer_advection_helpers.F + operators/mpas_tracer_advection_mono.F + operators/mpas_tracer_advection_std.F + operators/mpas_geometry_utils.F +) From 70edc4935e74b53bcc29a098d5caadd02841fa13 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 29 Oct 2019 15:01:11 -0600 Subject: [PATCH 029/331] Add optional argument keep_head_ptr to mpas_deallocate_field routines In cases where we need to deallocate a field that is an element of an array of field types, we could not pass an element of this field array to the mpas_deallocate_field routine, since the argument was a pointer. The field argument to the mpas_deallocate_field routines is now a target rather than a pointer, which allows elements of arrays of fields to be deallocated. However, since we cannot deallocate an individual element of an array, an optional argument, keep_head_ptr, has been added. When set to true, the mpas_deallocate_field routine will not attempt to deallocate the argument to the routine (though the contents of that argument's field type -- array, constituentNames, and attLists -- will be deallocated). Now, it is possible to deallocate an array of field types, e.g.: type (field1DReal), dimension(:), allocatable :: field_array ... code that allocates the field_array ... do i=1,size(field_array) call mpas_deallocate_field(field_array(i), keep_head_ptr=.true.) end do deallocate(field_array) *** Note: Deallocating an allocated pointer to a single field works as before, with the exception that the actual argument to the mpas_deallocate_field routine is not nullified (since the dummy argument is now a target and not a pointer). Therefore, it is recommended to explicitly nullify the actual argument after a call to mpas_deallocate_field, e.g., type (field1DReal), pointer :: f ... code that allocates f ... call mpas_deallocate_field(f) nullify(f) This commit also adds code to the mpas_deallocate_field routines to deallocate the constituentNames member of the field type if is allocated. --- src/framework/mpas_field_routines.F | 967 ++++++++++++++++++---------- 1 file changed, 626 insertions(+), 341 deletions(-) diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index a5f6960749..5fa8abc055 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -1388,43 +1388,65 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_logical +! routine mpas_deallocate_field0D_logical ! -!> \brief MPAS 0D logical deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D logical field. +!> This routine deallocates a 0D int field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_logical(f)!{{{ - type (field0dLogical), pointer :: f !< Input: Field to deallocate - type (field0dLogical), pointer :: f_cursor + subroutine mpas_deallocate_field0d_logical(f, keep_head_ptr)!{{{ + + implicit none + + type (field0dLogical), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field0dLogical), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - + + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if - deallocate(f_cursor) - f_cursor => f - end do + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_logical!}}} @@ -1432,43 +1454,65 @@ end subroutine mpas_deallocate_field0d_logical!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_integer +! routine mpas_deallocate_field0D_integer ! -!> \brief MPAS 0D integer deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D integer field. +!> This routine deallocates a 0D int field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_integer(f)!{{{ - type (field0dInteger), pointer :: f !< Input: Field to deallocate - type (field0dInteger), pointer :: f_cursor + subroutine mpas_deallocate_field0d_integer(f, keep_head_ptr)!{{{ + + implicit none + + type (field0dInteger), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field0dInteger), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - + + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - f_cursor => f - end do + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_integer!}}} @@ -1478,45 +1522,67 @@ end subroutine mpas_deallocate_field0d_integer!}}} ! ! routine mpas_deallocate_field1D_integer ! -!> \brief MPAS 1D integer deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 1D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D integer field. +!> This routine deallocates a 1D int field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_integer(f)!{{{ - type (field1dInteger), pointer :: f !< Input: Field to deallocate - type (field1dInteger), pointer :: f_cursor + subroutine mpas_deallocate_field1d_integer(f, keep_head_ptr)!{{{ + + implicit none + + type (field1dInteger), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field1dInteger), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - - f_cursor => f - end do + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_integer!}}} @@ -1526,45 +1592,67 @@ end subroutine mpas_deallocate_field1d_integer!}}} ! ! routine mpas_deallocate_field2D_integer ! -!> \brief MPAS 2D integer deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 2D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 2D integer field. +!> This routine deallocates a 2D int field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_integer(f)!{{{ - type (field2dInteger), pointer :: f !< Input: Field to deallocate - type (field2dInteger), pointer :: f_cursor + subroutine mpas_deallocate_field2d_integer(f, keep_head_ptr)!{{{ + + implicit none + + type (field2dInteger), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field2dInteger), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - - f_cursor => f - end do + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_integer!}}} @@ -1574,45 +1662,67 @@ end subroutine mpas_deallocate_field2d_integer!}}} ! ! routine mpas_deallocate_field3D_integer ! -!> \brief MPAS 3D integer deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 3D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 3D integer field. +!> This routine deallocates a 3D int field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_integer(f)!{{{ - type (field3dInteger), pointer :: f !< Input: Field to deallocate - type (field3dInteger), pointer :: f_cursor + subroutine mpas_deallocate_field3d_integer(f, keep_head_ptr)!{{{ + + implicit none + + type (field3dInteger), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field3dInteger), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - - f_cursor => f - end do + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_integer!}}} @@ -1620,44 +1730,65 @@ end subroutine mpas_deallocate_field3d_integer!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_real +! routine mpas_deallocate_field0D_real ! !> \brief MPAS 0D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D real field. +!> This routine deallocates a 0D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_real(f)!{{{ - type (field0dReal), pointer :: f !< Input: Field to deallocate - type (field0dReal), pointer :: f_cursor + subroutine mpas_deallocate_field0d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field0dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field0dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - f_cursor => f + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if if ( threadNum == 0 ) then - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - - f_cursor => f - end do + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_real!}}} @@ -1668,44 +1799,66 @@ end subroutine mpas_deallocate_field0d_real!}}} ! routine mpas_deallocate_field1D_real ! !> \brief MPAS 1D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D real field. +!> This routine deallocates a 1D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_real(f)!{{{ - type (field1dReal), pointer :: f !< Input: Field to deallocate - type (field1dReal), pointer :: f_cursor + subroutine mpas_deallocate_field1d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field1dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field1dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if - f_cursor => f - end do + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_real!}}} @@ -1716,44 +1869,66 @@ end subroutine mpas_deallocate_field1d_real!}}} ! routine mpas_deallocate_field2D_real ! !> \brief MPAS 2D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 2D real field. +!> This routine deallocates a 2D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_real(f)!{{{ - type (field2dReal), pointer :: f !< Input: Field to deallocate - type (field2dReal), pointer :: f_cursor + subroutine mpas_deallocate_field2d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field2dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field2dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - deallocate(f_cursor) + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_real!}}} @@ -1764,44 +1939,66 @@ end subroutine mpas_deallocate_field2d_real!}}} ! routine mpas_deallocate_field3D_real ! !> \brief MPAS 3D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 3D real field. +!> This routine deallocates a 3D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_real(f)!{{{ - type (field3dReal), pointer :: f !< Input: Field to deallocate - type (field3dReal), pointer :: f_cursor + subroutine mpas_deallocate_field3d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field3dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field3dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_real!}}} @@ -1812,44 +2009,66 @@ end subroutine mpas_deallocate_field3d_real!}}} ! routine mpas_deallocate_field4D_real ! !> \brief MPAS 4D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 4D real field. +!> This routine deallocates a 4D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field4d_real(f)!{{{ - type (field4dReal), pointer :: f !< Input: Field to deallocate - type (field4dReal), pointer :: f_cursor + subroutine mpas_deallocate_field4d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field4dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field4dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if - f_cursor => f - end do + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field4d_real!}}} @@ -1860,44 +2079,66 @@ end subroutine mpas_deallocate_field4d_real!}}} ! routine mpas_deallocate_field5D_real ! !> \brief MPAS 5D real deallocation routine. -!> \author Doug Jacobsen +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 5D real field. +!> This routine deallocates a 5D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field5d_real(f)!{{{ - type (field5dReal), pointer :: f !< Input: Field to deallocate - type (field5dReal), pointer :: f_cursor + subroutine mpas_deallocate_field5d_real(f, keep_head_ptr)!{{{ + + implicit none + + type (field5dReal), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field5dReal), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if - deallocate(f_cursor) + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - f_cursor => f - end do + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field5d_real!}}} @@ -1907,41 +2148,63 @@ end subroutine mpas_deallocate_field5d_real!}}} ! ! routine mpas_deallocate_field0D_char ! -!> \brief MPAS 0D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 0D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D character field. +!> This routine deallocates a 0D real field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_char(f)!{{{ - type (field0dChar), pointer :: f !< Input: Field to deallocate - type (field0dChar), pointer :: f_cursor + subroutine mpas_deallocate_field0d_char(f, keep_head_ptr)!{{{ + + implicit none + + type (field0dChar), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field0dChar), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next - deallocate(f_cursor) - f_cursor => f - end do + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if + + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_char!}}} @@ -1951,45 +2214,67 @@ end subroutine mpas_deallocate_field0d_char!}}} ! ! routine mpas_deallocate_field1D_char ! -!> \brief MPAS 1D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 1D char deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D character field. +!> This routine deallocates a 1D char field. If the optional argument +!> keep_head_ptr is .true., the field type pointed to by f will not be +!> deallocated -- only the contents (array, attLists, constituentNames) +!> will be deallocated. If the field contains multiple blocks, all memory +!> for all blocks other than the first (including the field types themselves) +!> will be deallocated. +!> +!> The principal use fo rthe keep_head_ptr argument is for situations in +!> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_char(f)!{{{ - type (field1dChar), pointer :: f !< Input: Field to deallocate - type (field1dChar), pointer :: f_cursor + subroutine mpas_deallocate_field1d_char(f, keep_head_ptr)!{{{ + + implicit none + + type (field1dChar), target :: f !< Input: Field to deallocate + logical, intent(in), optional :: keep_head_ptr + + type (field1dChar), pointer :: f_cursor, f_next + logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() + if (present(keep_head_ptr)) then + local_keep_head_ptr = keep_head_ptr + else + local_keep_head_ptr = .false. + end if + if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + deallocate(f_cursor) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_char!}}} From 94200c91bf565f608a3831b6f4331e83367c8e7e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 29 Oct 2019 15:16:20 -0600 Subject: [PATCH 030/331] Fix memory leak in mpas_pool_destroy_pool Previously, the mpas_pool_destroy_pool routine simply deallocated the 'array' component of the fields that were stored in the pool to be freed. This led to a memory leak, which is fixed by calling mpas_deallocate_field for each field in a pool. --- src/framework/mpas_pool_routines.F | 110 +++++++++-------------------- 1 file changed, 34 insertions(+), 76 deletions(-) diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index c362c770d8..85263c74e8 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -249,137 +249,95 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - deallocate(dptr % r0, stat=local_err) + call mpas_deallocate_field(dptr % r0) else if (associated(dptr % r1)) then - if (associated(dptr % r1 % array)) then - deallocate(dptr % r1 % array, stat=local_err) - end if - - deallocate(dptr % r1, stat=local_err) + call mpas_deallocate_field(dptr % r1) else if (associated(dptr % r2)) then - if (associated(dptr % r2 % array)) then - deallocate(dptr % r2 % array, stat=local_err) - end if - - deallocate(dptr % r2, stat=local_err) + call mpas_deallocate_field(dptr % r2) else if (associated(dptr % r3)) then - if (associated(dptr % r3 % array)) then - deallocate(dptr % r3 % array, stat=local_err) - end if - - deallocate(dptr % r3, stat=local_err) + call mpas_deallocate_field(dptr % r3) else if (associated(dptr % r4)) then - if (associated(dptr % r4 % array)) then - deallocate(dptr % r4 % array, stat=local_err) - end if - - deallocate(dptr % r4, stat=local_err) + call mpas_deallocate_field(dptr % r4) else if (associated(dptr % r5)) then - if (associated(dptr % r5 % array)) then - deallocate(dptr % r5 % array, stat=local_err) - end if - - deallocate(dptr % r5, stat=local_err) + call mpas_deallocate_field(dptr % r5) else if (associated(dptr % i0)) then - deallocate(dptr % i0, stat=local_err) + call mpas_deallocate_field(dptr % i0) else if (associated(dptr % i1)) then - if (associated(dptr % i1 % array)) then - deallocate(dptr % i1 % array, stat=local_err) - end if - - deallocate(dptr % i1, stat=local_err) + call mpas_deallocate_field(dptr % i1) else if (associated(dptr % i2)) then - if (associated(dptr % i2 % array)) then - deallocate(dptr % i2 % array, stat=local_err) - end if - - deallocate(dptr % i2, stat=local_err) + call mpas_deallocate_field(dptr % i2) else if (associated(dptr % i3)) then - if (associated(dptr % i3 % array)) then - deallocate(dptr % i3 % array, stat=local_err) - end if - - deallocate(dptr % i3, stat=local_err) + call mpas_deallocate_field(dptr % i3) else if (associated(dptr % c0)) then - deallocate(dptr % c0, stat=local_err) + call mpas_deallocate_field(dptr % c0) else if (associated(dptr % c1)) then - if (associated(dptr % c1 % array)) then - deallocate(dptr % c1 % array, stat=local_err) - end if - - deallocate(dptr % c1, stat=local_err) + call mpas_deallocate_field(dptr % c1) else if (associated(dptr % l0)) then - deallocate(dptr % l0, stat=local_err) + call mpas_deallocate_field(dptr % l0) else if (associated(dptr % r0a)) then + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field(dptr % r0a(j), keep_head_ptr=.true.) + end do deallocate(dptr % r0a, stat=local_err) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r1a(j) % array)) then - deallocate(dptr % r1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % r1a(j), keep_head_ptr=.true.) end do deallocate(dptr % r1a, stat=local_err) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r2a(j) % array)) then - deallocate(dptr % r2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % r2a(j), keep_head_ptr=.true.) end do deallocate(dptr % r2a, stat=local_err) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r3a(j) % array)) then - deallocate(dptr % r3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % r3a(j), keep_head_ptr=.true.) end do deallocate(dptr % r3a, stat=local_err) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r4a(j) % array)) then - deallocate(dptr % r4a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % r4a(j), keep_head_ptr=.true.) end do deallocate(dptr % r4a, stat=local_err) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r5a(j) % array)) then - deallocate(dptr % r5a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % r5a(j), keep_head_ptr=.true.) end do deallocate(dptr % r5a, stat=local_err) else if (associated(dptr % i0a)) then + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field(dptr % i0a(j), keep_head_ptr=.true.) + end do deallocate(dptr % i0a, stat=local_err) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i1a(j) % array)) then - deallocate(dptr % i1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % i1a(j), keep_head_ptr=.true.) end do deallocate(dptr % i1a, stat=local_err) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i2a(j) % array)) then - deallocate(dptr % i2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % i2a(j), keep_head_ptr=.true.) end do deallocate(dptr % i2a, stat=local_err) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i3a(j) % array)) then - deallocate(dptr % i3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % i3a(j), keep_head_ptr=.true.) end do deallocate(dptr % i3a, stat=local_err) else if (associated(dptr % c0a)) then + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field(dptr % c0a(j), keep_head_ptr=.true.) + end do deallocate(dptr % c0a, stat=local_err) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % c1a(j) % array)) then - deallocate(dptr % c1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field(dptr % c1a(j), keep_head_ptr=.true.) end do deallocate(dptr % c1a, stat=local_err) else if (associated(dptr % l0a)) then + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field(dptr % l0a(j), keep_head_ptr=.true.) + end do deallocate(dptr % l0a, stat=local_err) else call pool_mesg('While destroying pool, member '//trim(ptr % key)//' has no valid field pointers.') From 0bccf662eed00fb1d714c6aa2fa580329c68cf81 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 29 Oct 2019 15:18:42 -0600 Subject: [PATCH 031/331] Fix bug in mpas_pool_link_parinfo for 4-d real field with a time dimension When querying the decomposed dimension for a 4-d real field with a time dimension in the mpas_pool_link_parinfo routine, the routine previously attempted to access poolMem % r4 % dimNames(4), when it should have accessed poolMem % r4a(1) % dimNames(4) . The former access is appropriate only for 4-d real fields with no time dimension. pool_get_member_decomp_type(poolMem % r4a(1) % dimNames(4)) --- src/framework/mpas_pool_routines.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 85263c74e8..599a0b1a0f 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -1819,7 +1819,7 @@ recursive subroutine mpas_pool_link_parinfo(block, inPool)!{{{ end if else if (poolItr % nDims == 4) then if (poolItr % nTimeLevels > 1) then - decompType = pool_get_member_decomp_type(poolMem % r4 % dimNames(4)) + decompType = pool_get_member_decomp_type(poolMem % r4a(1) % dimNames(4)) if (decompType == MPAS_DECOMP_CELLS) then do i = 1, poolItr % nTimeLevels From b0c35c390b0be8bca283c5e91a8e9d35c0df762d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 7 Nov 2019 11:46:34 -0700 Subject: [PATCH 032/331] Fix issue in deallocating fields with multiple time levels and multiple blocks When the keep_head_ptr argument to mpas_deallocate_field was .true., the mpas_deallocate_field routines previously attempted to deallocate all blocks for the input field besides the first block. This led to problems in freeing fields with multiple blocks and multiple time levels, since the blocks of the field were each elements of an array of fields (the array containing the time levels). Now, setting the optional argument keep_head_ptr to .true. in a call to one of the mpas_deallocate_field routines will prevent the containing field type for all blocks from being deallocated. Memory leaks are still avoided, since the field arrays for all blocks should eventually be deallocated (e.g., with calls to mpas_deallocate_block in the loop over blocks in lines 124-128 of mpas_domain_routines.F). --- src/framework/mpas_field_routines.F | 80 +++++++++++------------------ 1 file changed, 29 insertions(+), 51 deletions(-) diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index 5fa8abc055..5616df32ec 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -1394,14 +1394,12 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D int field. If the optional argument +!> This routine deallocates a 0D logical field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1441,7 +1439,7 @@ subroutine mpas_deallocate_field0d_logical(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1463,11 +1461,9 @@ end subroutine mpas_deallocate_field0d_logical!}}} !> This routine deallocates a 0D int field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1507,7 +1503,7 @@ subroutine mpas_deallocate_field0d_integer(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1529,11 +1525,9 @@ end subroutine mpas_deallocate_field0d_integer!}}} !> This routine deallocates a 1D int field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1577,7 +1571,7 @@ subroutine mpas_deallocate_field1d_integer(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1599,11 +1593,11 @@ end subroutine mpas_deallocate_field1d_integer!}}} !> This routine deallocates a 2D int field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory +!> will be deallocated. !> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1647,7 +1641,7 @@ subroutine mpas_deallocate_field2d_integer(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1669,11 +1663,9 @@ end subroutine mpas_deallocate_field2d_integer!}}} !> This routine deallocates a 3D int field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1717,7 +1709,7 @@ subroutine mpas_deallocate_field3d_integer(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1739,11 +1731,9 @@ end subroutine mpas_deallocate_field3d_integer!}}} !> This routine deallocates a 0D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1783,7 +1773,7 @@ subroutine mpas_deallocate_field0d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1805,11 +1795,9 @@ end subroutine mpas_deallocate_field0d_real!}}} !> This routine deallocates a 1D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1853,7 +1841,7 @@ subroutine mpas_deallocate_field1d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1875,11 +1863,9 @@ end subroutine mpas_deallocate_field1d_real!}}} !> This routine deallocates a 2D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1923,7 +1909,7 @@ subroutine mpas_deallocate_field2d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -1945,11 +1931,11 @@ end subroutine mpas_deallocate_field2d_real!}}} !> This routine deallocates a 3D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory +!> will be deallocated. !> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -1993,7 +1979,7 @@ subroutine mpas_deallocate_field3d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -2015,11 +2001,9 @@ end subroutine mpas_deallocate_field3d_real!}}} !> This routine deallocates a 4D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -2063,7 +2047,7 @@ subroutine mpas_deallocate_field4d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -2085,11 +2069,9 @@ end subroutine mpas_deallocate_field4d_real!}}} !> This routine deallocates a 5D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -2133,7 +2115,7 @@ subroutine mpas_deallocate_field5d_real(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -2155,11 +2137,9 @@ end subroutine mpas_deallocate_field5d_real!}}} !> This routine deallocates a 0D real field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -2199,7 +2179,7 @@ subroutine mpas_deallocate_field0d_char(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if @@ -2221,11 +2201,9 @@ end subroutine mpas_deallocate_field0d_char!}}} !> This routine deallocates a 1D char field. If the optional argument !> keep_head_ptr is .true., the field type pointed to by f will not be !> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. If the field contains multiple blocks, all memory -!> for all blocks other than the first (including the field types themselves) !> will be deallocated. !> -!> The principal use fo rthe keep_head_ptr argument is for situations in +!> The principal use for the keep_head_ptr argument is for situations in !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- @@ -2269,7 +2247,7 @@ subroutine mpas_deallocate_field1d_char(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if ((.not. local_keep_head_ptr) .or. (.not. associated(f_cursor, f))) then + if (.not. local_keep_head_ptr) then deallocate(f_cursor) end if From 90032e30fb0096bea81cc20ddea22028d6a9c836 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 7 Nov 2019 11:55:03 -0700 Subject: [PATCH 033/331] Add new interface, mpas_deallocate_field_target, for deallocating fields The previous implementations of the mpas_deallocate_field routines would not return a nullified field pointer when the optional keep_head_ptr argument was .false., since the dummy argument to these routines had the target attribute rather than the pointer attribute. This could lead to problems if the calling code didn't explicitly nullify the field pointer but later checked on the association status of that pointer. To remedy this issue, a new interface, mpas_deallocate_field_target, has been implemented to handle the deallocation of fields that are elements of field arrays. This interface is principally used when deallocating fields with multiple time levels. The mpas_deallocate_field interface now reverts to declaring the dummy argument with the pointer attribute; these routines are implemented by a call to mpas_deallocate_field_target followed by an explicit nullification of the dummy argument. --- src/framework/mpas_field_routines.F | 482 +++++++++++++++++++++++++--- src/framework/mpas_pool_routines.F | 26 +- 2 files changed, 457 insertions(+), 51 deletions(-) diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index 5616df32ec..dea3ab1e25 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -108,6 +108,22 @@ module mpas_field_routines module procedure mpas_deallocate_field1d_char end interface + interface mpas_deallocate_field_target + module procedure mpas_deallocate_field0d_logical_target + module procedure mpas_deallocate_field0d_integer_target + module procedure mpas_deallocate_field1d_integer_target + module procedure mpas_deallocate_field2d_integer_target + module procedure mpas_deallocate_field3d_integer_target + module procedure mpas_deallocate_field0d_real_target + module procedure mpas_deallocate_field1d_real_target + module procedure mpas_deallocate_field2d_real_target + module procedure mpas_deallocate_field3d_real_target + module procedure mpas_deallocate_field4d_real_target + module procedure mpas_deallocate_field5d_real_target + module procedure mpas_deallocate_field0d_char_target + module procedure mpas_deallocate_field1d_char_target + end interface + contains !*********************************************************************** @@ -1391,6 +1407,396 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} ! routine mpas_deallocate_field0D_logical ! !> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d logical field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_logical(f)!{{{ + + implicit none + + type (field0dLogical), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field0d_logical!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_integer +! +!> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_integer(f)!{{{ + + implicit none + + type (field0dInteger), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field0d_integer!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_integer +! +!> \brief MPAS 1D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 1-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_integer(f)!{{{ + + implicit none + + type (field1dInteger), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field1d_integer!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_integer +! +!> \brief MPAS 2D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 2-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_integer(f)!{{{ + + implicit none + + type (field2dInteger), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field2d_integer!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_integer +! +!> \brief MPAS 3D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 3-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_integer(f)!{{{ + + implicit none + + type (field3dInteger), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field3d_integer!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_real +! +!> \brief MPAS 0D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_real(f)!{{{ + + implicit none + + type (field0dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field0d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_real +! +!> \brief MPAS 1D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 1-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_real(f)!{{{ + + implicit none + + type (field1dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field1d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_real +! +!> \brief MPAS 2D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 2-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_real(f)!{{{ + + implicit none + + type (field2dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field2d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_real +! +!> \brief MPAS 3D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 3-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_real(f)!{{{ + + implicit none + + type (field3dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field3d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field4D_real +! +!> \brief MPAS 4D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 4-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field4d_real(f)!{{{ + + implicit none + + type (field4dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field4d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field5D_real +! +!> \brief MPAS 5D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 5-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field5d_real(f)!{{{ + + implicit none + + type (field5dReal), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field5d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_char +! +!> \brief MPAS 0D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_char(f)!{{{ + + implicit none + + type (field0dChar), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field0d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_char +! +!> \brief MPAS 1D char deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 1-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_char(f)!{{{ + + implicit none + + type (field1dChar), pointer :: f !< Input: Field to deallocate + + call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + nullify(f) + + end subroutine mpas_deallocate_field1d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_logical_target +! +!> \brief MPAS 0D int deallocation routine. !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details @@ -1403,7 +1809,7 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_logical(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_logical_target(f, keep_head_ptr)!{{{ implicit none @@ -1447,12 +1853,12 @@ subroutine mpas_deallocate_field0d_logical(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field0d_logical!}}} + end subroutine mpas_deallocate_field0d_logical_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0D_integer +! routine mpas_deallocate_field0D_integer_target ! !> \brief MPAS 0D int deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1467,7 +1873,7 @@ end subroutine mpas_deallocate_field0d_logical!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_integer(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_integer_target(f, keep_head_ptr)!{{{ implicit none @@ -1511,12 +1917,12 @@ subroutine mpas_deallocate_field0d_integer(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field0d_integer!}}} + end subroutine mpas_deallocate_field0d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field1D_integer +! routine mpas_deallocate_field1D_integer_target ! !> \brief MPAS 1D int deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1531,7 +1937,7 @@ end subroutine mpas_deallocate_field0d_integer!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_integer(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_integer_target(f, keep_head_ptr)!{{{ implicit none @@ -1579,12 +1985,12 @@ subroutine mpas_deallocate_field1d_integer(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field1d_integer!}}} + end subroutine mpas_deallocate_field1d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field2D_integer +! routine mpas_deallocate_field2D_integer_target ! !> \brief MPAS 2D int deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1601,7 +2007,7 @@ end subroutine mpas_deallocate_field1d_integer!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_integer(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field2d_integer_target(f, keep_head_ptr)!{{{ implicit none @@ -1649,12 +2055,12 @@ subroutine mpas_deallocate_field2d_integer(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field2d_integer!}}} + end subroutine mpas_deallocate_field2d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field3D_integer +! routine mpas_deallocate_field3D_integer_target ! !> \brief MPAS 3D int deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1669,7 +2075,7 @@ end subroutine mpas_deallocate_field2d_integer!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_integer(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field3d_integer_target(f, keep_head_ptr)!{{{ implicit none @@ -1717,12 +2123,12 @@ subroutine mpas_deallocate_field3d_integer(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field3d_integer!}}} + end subroutine mpas_deallocate_field3d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0D_real +! routine mpas_deallocate_field0D_real_target ! !> \brief MPAS 0D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1737,7 +2143,7 @@ end subroutine mpas_deallocate_field3d_integer!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -1781,12 +2187,12 @@ subroutine mpas_deallocate_field0d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field0d_real!}}} + end subroutine mpas_deallocate_field0d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field1D_real +! routine mpas_deallocate_field1D_real_target ! !> \brief MPAS 1D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1801,7 +2207,7 @@ end subroutine mpas_deallocate_field0d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -1849,12 +2255,12 @@ subroutine mpas_deallocate_field1d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field1d_real!}}} + end subroutine mpas_deallocate_field1d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field2D_real +! routine mpas_deallocate_field2D_real_target ! !> \brief MPAS 2D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1869,7 +2275,7 @@ end subroutine mpas_deallocate_field1d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field2d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -1917,12 +2323,12 @@ subroutine mpas_deallocate_field2d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field2d_real!}}} + end subroutine mpas_deallocate_field2d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field3D_real +! routine mpas_deallocate_field3D_real_target ! !> \brief MPAS 3D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -1939,7 +2345,7 @@ end subroutine mpas_deallocate_field2d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field3d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -1987,12 +2393,12 @@ subroutine mpas_deallocate_field3d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field3d_real!}}} + end subroutine mpas_deallocate_field3d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field4D_real +! routine mpas_deallocate_field4D_real_target ! !> \brief MPAS 4D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -2007,7 +2413,7 @@ end subroutine mpas_deallocate_field3d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field4d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field4d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -2055,12 +2461,12 @@ subroutine mpas_deallocate_field4d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field4d_real!}}} + end subroutine mpas_deallocate_field4d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field5D_real +! routine mpas_deallocate_field5D_real_target ! !> \brief MPAS 5D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -2075,7 +2481,7 @@ end subroutine mpas_deallocate_field4d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field5d_real(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field5d_real_target(f, keep_head_ptr)!{{{ implicit none @@ -2123,12 +2529,12 @@ subroutine mpas_deallocate_field5d_real(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field5d_real!}}} + end subroutine mpas_deallocate_field5d_real_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0D_char +! routine mpas_deallocate_field0D_char_target ! !> \brief MPAS 0D real deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -2143,7 +2549,7 @@ end subroutine mpas_deallocate_field5d_real!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_char(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_char_target(f, keep_head_ptr)!{{{ implicit none @@ -2187,12 +2593,12 @@ subroutine mpas_deallocate_field0d_char(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field0d_char!}}} + end subroutine mpas_deallocate_field0d_char_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field1D_char +! routine mpas_deallocate_field1D_char_target ! !> \brief MPAS 1D char deallocation routine. !> \author Doug Jacobsen, Michael G. Duda @@ -2207,7 +2613,7 @@ end subroutine mpas_deallocate_field0d_char!}}} !> which elemements of an array of fields need to be deallocated. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_char(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_char_target(f, keep_head_ptr)!{{{ implicit none @@ -2255,7 +2661,7 @@ subroutine mpas_deallocate_field1d_char(f, keep_head_ptr)!{{{ end do end if - end subroutine mpas_deallocate_field1d_char!}}} + end subroutine mpas_deallocate_field1d_char_target!}}} !*********************************************************************** diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 599a0b1a0f..a4d4a414c6 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -276,67 +276,67 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ call mpas_deallocate_field(dptr % l0) else if (associated(dptr % r0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r0a(j), keep_head_ptr=.true.) end do deallocate(dptr % r0a, stat=local_err) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r1a(j), keep_head_ptr=.true.) end do deallocate(dptr % r1a, stat=local_err) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r2a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r2a(j), keep_head_ptr=.true.) end do deallocate(dptr % r2a, stat=local_err) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r3a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r3a(j), keep_head_ptr=.true.) end do deallocate(dptr % r3a, stat=local_err) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r4a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r4a(j), keep_head_ptr=.true.) end do deallocate(dptr % r4a, stat=local_err) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % r5a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r5a(j), keep_head_ptr=.true.) end do deallocate(dptr % r5a, stat=local_err) else if (associated(dptr % i0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % i0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i0a(j), keep_head_ptr=.true.) end do deallocate(dptr % i0a, stat=local_err) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % i1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i1a(j), keep_head_ptr=.true.) end do deallocate(dptr % i1a, stat=local_err) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % i2a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i2a(j), keep_head_ptr=.true.) end do deallocate(dptr % i2a, stat=local_err) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % i3a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i3a(j), keep_head_ptr=.true.) end do deallocate(dptr % i3a, stat=local_err) else if (associated(dptr % c0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % c0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c0a(j), keep_head_ptr=.true.) end do deallocate(dptr % c0a, stat=local_err) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % c1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c1a(j), keep_head_ptr=.true.) end do deallocate(dptr % c1a, stat=local_err) else if (associated(dptr % l0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field(dptr % l0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % l0a(j), keep_head_ptr=.true.) end do deallocate(dptr % l0a, stat=local_err) else From 7ca67692793366b6383f64f4efa17ad308405f13 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 7 Nov 2019 14:05:02 -0700 Subject: [PATCH 034/331] Fix issue in destroying pools with multi-block fields with a single time level The mpas_pool_destroy_pool routine previously called the mpas_deallocate_field routine for fields with only a single time level. This works well for fields that have just one block per MPI task, but leads to invalid memory references when fields have multiple blocks: calling mpas_pool_destroy_pool for the pool in the first block frees memeory for all blocks of a field, leaving the field pointers in subsequnt blocks pointing to deallocated memory. As a work-around, the mpas_pool_destroy_pool now calls mpas_deallocate_field_target with the keep_head_ptr argument set to .true. so that the field pointed to by pools from other blocks will not be deallocated. Then, only for the field owned by a block, the field is explicitly deallocated after the call to mpas_deallocate_field_target. --- src/framework/mpas_pool_routines.F | 39 ++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index a4d4a414c6..15afb36de3 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -249,31 +249,44 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - call mpas_deallocate_field(dptr % r0) + call mpas_deallocate_field_target(dptr % r0, keep_head_ptr=.true.) + deallocate(dptr % r0) else if (associated(dptr % r1)) then - call mpas_deallocate_field(dptr % r1) + call mpas_deallocate_field_target(dptr % r1, keep_head_ptr=.true.) + deallocate(dptr % r1) else if (associated(dptr % r2)) then - call mpas_deallocate_field(dptr % r2) + call mpas_deallocate_field_target(dptr % r2, keep_head_ptr=.true.) + deallocate(dptr % r2) else if (associated(dptr % r3)) then - call mpas_deallocate_field(dptr % r3) + call mpas_deallocate_field_target(dptr % r3, keep_head_ptr=.true.) + deallocate(dptr % r3) else if (associated(dptr % r4)) then - call mpas_deallocate_field(dptr % r4) + call mpas_deallocate_field_target(dptr % r4, keep_head_ptr=.true.) + deallocate(dptr % r4) else if (associated(dptr % r5)) then - call mpas_deallocate_field(dptr % r5) + call mpas_deallocate_field_target(dptr % r5, keep_head_ptr=.true.) + deallocate(dptr % r5) else if (associated(dptr % i0)) then - call mpas_deallocate_field(dptr % i0) + call mpas_deallocate_field_target(dptr % i0, keep_head_ptr=.true.) + deallocate(dptr % i0) else if (associated(dptr % i1)) then - call mpas_deallocate_field(dptr % i1) + call mpas_deallocate_field_target(dptr % i1, keep_head_ptr=.true.) + deallocate(dptr % i1) else if (associated(dptr % i2)) then - call mpas_deallocate_field(dptr % i2) + call mpas_deallocate_field_target(dptr % i2, keep_head_ptr=.true.) + deallocate(dptr % i2) else if (associated(dptr % i3)) then - call mpas_deallocate_field(dptr % i3) + call mpas_deallocate_field_target(dptr % i3, keep_head_ptr=.true.) + deallocate(dptr % i3) else if (associated(dptr % c0)) then - call mpas_deallocate_field(dptr % c0) + call mpas_deallocate_field_target(dptr % c0, keep_head_ptr=.true.) + deallocate(dptr % c0) else if (associated(dptr % c1)) then - call mpas_deallocate_field(dptr % c1) + call mpas_deallocate_field_target(dptr % c1, keep_head_ptr=.true.) + deallocate(dptr % c1) else if (associated(dptr % l0)) then - call mpas_deallocate_field(dptr % l0) + call mpas_deallocate_field_target(dptr % l0, keep_head_ptr=.true.) + deallocate(dptr % l0) else if (associated(dptr % r0a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r0a(j), keep_head_ptr=.true.) From 81bf18a88d33bd1110bc4b64f59af04324de9e6a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 8 Nov 2019 14:21:13 -0700 Subject: [PATCH 035/331] Add pools for CAM dynamics import and export states The fields defined in the new dyn_in and dyn_out pools may be directly referenced by CAM-MPAS's dynamics import and export states, since the members of those states are pointers. Eventually, redundant versions of fields (e.g, uReconstructZonal and ux) that already exist elsewhere in the Registry.xml file should be avoided, but the final organization of CAM-MPAS's import and export states is yet unknown. --- src/core_atmosphere/Registry.xml | 159 +++++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index b4a10bc4c6..29f0cbf137 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2982,4 +2982,163 @@ #include "diagnostics/Registry_diagnostics.xml" + +#ifndef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +#endif + From feefd2d7b335bfb80064498ac5c0a5ef3f9ff853 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 13 Nov 2019 14:14:01 -0700 Subject: [PATCH 036/331] Add mpas_in_cell, mpas_mirror_point, and mpas_rotate_about_vector to operators Three new routines, mpas_in_cell, mpas_mirror_point, and mpas_rotate_about_vector are added to the mpas_geometry_utils module. Briefly, the routines provide the following: * mpas_in_cell: Given the Voronoi center and corner points of a cell, determine whether a point is inside the Voronoi cell * mpas_mirror_point: Given a point and a great-circle arc, find the mirror of the point on the other side of the arc * mpas_rotate_about_vector: Given a vector in R3 and a point, rotate the point by a specified angle about the vector --- src/operators/mpas_geometry_utils.F | 138 ++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) diff --git a/src/operators/mpas_geometry_utils.F b/src/operators/mpas_geometry_utils.F index 7ec62be6cb..ba9d49522a 100644 --- a/src/operators/mpas_geometry_utils.F +++ b/src/operators/mpas_geometry_utils.F @@ -1728,4 +1728,142 @@ subroutine mpas_spherical_linear_interp(pInterp, p0, p1, alpha) !{{{ end subroutine mpas_spherical_linear_interp !}}} + +!----------------------------------------------------------------------- +! routine mpas_rotate_about_vector +! +!> \brief Rotates a point about a vector in R3 +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Rotates the point (x,y,z) through an angle theta about the vector +!> originating at (a, b, c) and having direction (u, v, w). +! +!> Reference: https://sites.google.com/site/glennmurray/Home/rotation-matrices-and-formulas/rotation-about-an-arbitrary-axis-in-3-dimensions +! +!----------------------------------------------------------------------- + subroutine mpas_rotate_about_vector(x, y, z, theta, a, b, c, u, v, w, xp, yp, zp) + + implicit none + + real (kind=RKIND), intent(in) :: x, y, z, theta, a, b, c, u, v, w + real (kind=RKIND), intent(out) :: xp, yp, zp + + real (kind=RKIND) :: vw2, uw2, uv2 + real (kind=RKIND) :: m + + vw2 = v**2.0 + w**2.0 + uw2 = u**2.0 + w**2.0 + uv2 = u**2.0 + v**2.0 + m = sqrt(u**2.0 + v**2.0 + w**2.0) + + xp = (a*vw2 + u*(-b*v-c*w+u*x+v*y+w*z) + ((x-a)*vw2+u*(b*v+c*w-v*y-w*z))*cos(theta) + m*(-c*v+b*w-w*y+v*z)*sin(theta))/m**2.0 + yp = (b*uw2 + v*(-a*u-c*w+u*x+v*y+w*z) + ((y-b)*uw2+v*(a*u+c*w-u*x-w*z))*cos(theta) + m*( c*u-a*w+w*x-u*z)*sin(theta))/m**2.0 + zp = (c*uv2 + w*(-a*u-b*v+u*x+v*y+w*z) + ((z-c)*uv2+w*(a*u+b*v-u*x-v*y))*cos(theta) + m*(-b*u+a*v-v*x+u*y)*sin(theta))/m**2.0 + + end subroutine mpas_rotate_about_vector + + +!----------------------------------------------------------------------- +! routine mpas_mirror_point +! +!> \brief Finds the "mirror" of a point about a great-circle arc +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given the endpoints of a great-circle arc (A,B) and a point, computes +!> the location of the point on the opposite side of the arc along a great- +!> circle arc that intersects (A,B) at a right angle, and such that the arc +!> between the point and its mirror is bisected by (A,B). +!> +!> Assumptions: A, B, and the point to be reflected all lie on the surface +!> of the unit sphere. +! +!----------------------------------------------------------------------- + subroutine mpas_mirror_point(xPoint, yPoint, zPoint, xA, yA, zA, xB, yB, zB, xMirror, yMirror, zMirror) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xA, yA, zA + real(kind=RKIND), intent(in) :: xB, yB, zB + real(kind=RKIND), intent(out) :: xMirror, yMirror, zMirror + + real(kind=RKIND) :: alpha + + ! + ! Find the spherical angle between arcs AP and AB (where P is the point to be reflected) + ! + alpha = mpas_sphere_angle(xA, yA, zA, xPoint, yPoint, zPoint, xB, yB, zB) + + ! + ! Rotate the point to be reflected by twice alpha about the vector from the origin to A + ! + call mpas_rotate_about_vector(xPoint, yPoint, zPoint, 2.0_RKIND * alpha, 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xA, yA, zA, xMirror, yMirror, zMirror) + + end subroutine mpas_mirror_point + + +!----------------------------------------------------------------------- +! routine mpas_in_cell +! +!> \brief Determines whether a point is within a Voronoi cell +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given a point on the surface of the sphere, the corner points of a Voronoi +!> cell, and the generating point for that Voronoi cell, determines whether +!> the given point is within the Voronoi cell. +! +!----------------------------------------------------------------------- + logical function mpas_in_cell(xPoint, yPoint, zPoint, xCell, yCell, zCell, & + nEdgesOnCell, verticesOnCell, xVertex, yVertex, zVertex) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xCell, yCell, zCell + integer, intent(in) :: nEdgesOnCell + integer, dimension(:), intent(in) :: verticesOnCell + real(kind=RKIND), dimension(:), intent(in) :: xVertex, yVertex, zVertex + + integer :: i + integer :: vtx1, vtx2 + real(kind=RKIND) :: xNeighbor, yNeighbor, zNeighbor + real(kind=RKIND) :: inDist, outDist + real(kind=RKIND) :: radius + real(kind=RKIND) :: radius_inv + + radius = sqrt(xCell * xCell + yCell * yCell + zCell * zCell) + radius_inv = 1.0_RKIND / radius + + inDist = mpas_arc_length(xPoint, yPoint, zPoint, xCell, yCell, zCell) + + mpas_in_cell = .true. + + do i=1,nEdgesOnCell + vtx1 = verticesOnCell(i) + vtx2 = verticesOnCell(mod(i,nEdgesOnCell)+1) + + call mpas_mirror_point(xCell*radius_inv, yCell*radius_inv, zCell*radius_inv, & + xVertex(vtx1)*radius_inv, yVertex(vtx1)*radius_inv, zVertex(vtx1)*radius_inv, & + xVertex(vtx2)*radius_inv, yVertex(vtx2)*radius_inv, zVertex(vtx2)*radius_inv, & + xNeighbor, yNeighbor, zNeighbor) + + xNeighbor = xNeighbor * radius + yNeighbor = yNeighbor * radius + zNeighbor = zNeighbor * radius + + outDist = mpas_arc_length(xPoint, yPoint, zPoint, xNeighbor, yNeighbor, zNeighbor) + + if (outDist < inDist) then + mpas_in_cell = .false. + return + end if + + end do + + end function mpas_in_cell + end module mpas_geometry_utils From 4136dbf00d97d35f0fc34c6b5b1d40279b09bcc0 Mon Sep 17 00:00:00 2001 From: James Foucar Date: Sun, 17 Nov 2019 16:01:22 -0700 Subject: [PATCH 037/331] Fix bug in landice.cmake --- src/core_landice/landice.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/landice.cmake b/src/core_landice/landice.cmake index 232f3ccc9d..0d580d7800 100644 --- a/src/core_landice/landice.cmake +++ b/src/core_landice/landice.cmake @@ -71,7 +71,7 @@ list(APPEND RAW_SOURCES core_landice/mode_forward/mpas_li_subglacial_hydro.F ) -if (CPPFLAGS MATCHES ".*MPAS_LI_BUILD_INTERFACE.*") +if (CPPDEFS MATCHES ".*MPAS_LI_BUILD_INTERFACE.*") list(APPEND RAW_SOURCES core_landice/mode_forward/Interface_velocity_solver.cpp) endif() From 36955f867d0fb2cff48372caeda4710ecedc1b1d Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Wed, 11 Dec 2019 07:21:03 -0700 Subject: [PATCH 038/331] Write two new include files for config flags These files are now created on compile: - config_declare.inc: Declaration line for every variable in config pool. - config_get.inc: mpas_pool_get_config line for every variable in config pool. These additions require no changes for the cores, but it provides the option to include these files in a config module upon model initialization, so that one never needs to declare or get config variables anywhere else. --- src/tools/registry/gen_inc.c | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 06a31d2039..965efed6c5 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -530,7 +530,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ int in_subpool; - FILE *fd, *fd2; + FILE *fd, *fd2, *fcd, *fcg; const_core = ezxml_attr(registry, "core_abbrev"); @@ -538,6 +538,8 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fd = fopen("namelist_defines.inc", "w+"); fd2 = fopen("namelist_call.inc", "w+"); + fcd = fopen("config_declare.inc", "w+"); + fcg = fopen("config_get.inc", "w+"); fortprintf(fd2, " function %s_setup_namelists(configPool, namelistFilename, dminfo) result(iErr)\n", core_string); fortprintf(fd2, " use mpas_derived_types\n"); @@ -599,7 +601,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd, " integer :: ierr\n"); fortprintf(fd, "\n"); - // Define variable defintions prior to reading the namelist in. + // Define variable definitions prior to reading the namelist in. for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ nmloptname = ezxml_attr(nmlopt_xml, "name"); nmlopttype = ezxml_attr(nmlopt_xml, "type"); @@ -611,9 +613,12 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ if(strncmp(nmlopttype, "real", 1024) == 0){ fortprintf(fd, " real (kind=RKIND) :: %s = %lf\n", nmloptname, (double)atof(nmloptval)); + fortprintf(fcd, " real (kind=RKIND), pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "integer", 1024) == 0){ fortprintf(fd, " integer :: %s = %d\n", nmloptname, atoi(nmloptval)); + fortprintf(fcd, " integer, pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + fortprintf(fcd, " logical, pointer :: %s\n", nmloptname); if(strncmp(nmloptval, "true", 1024) == 0 || strncmp(nmloptval, ".true.", 1024) == 0){ fortprintf(fd, " logical :: %s = .true.\n", nmloptname); } else { @@ -621,9 +626,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ } } else if(strncmp(nmlopttype, "character", 1024) == 0){ fortprintf(fd, " character (len=StrKIND) :: %s = '%s'\n", nmloptname, nmloptval); + fortprintf(fcd, " character (len=StrKIND), pointer :: %s\n", nmloptname); } } fortprintf(fd, "\n"); + fortprintf(fcd, "\n"); // Define the namelist block, to read the namelist record in. fortprintf(fd, " namelist /%s/ &\n", nmlrecname); @@ -704,8 +711,10 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ nmloptname = ezxml_attr(nmlopt_xml, "name"); fortprintf(fd, " call mpas_pool_add_config(%s, '%s', %s)\n", pool_name, nmloptname, nmloptname); + fortprintf(fcg, " call mpas_pool_get_config(configPool, '%s', %s)\n", nmloptname, nmloptname); } fortprintf(fd, "\n"); + fortprintf(fcg, "\n"); // End new subroutine for namelist record. fortprintf(fd, " end subroutine %s_setup_nmlrec_%s\n", core_string, nmlrecname); @@ -716,6 +725,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd2, " close(unitNumber)\n"); fortprintf(fd2, " end function %s_setup_namelists\n", core_string); + fclose(fd); + fclose(fd2); + fclose(fcd); + fclose(fcg); + return 0; }/*}}}*/ From 71048edceaa0cb8362c0627357b8c4a5094af69e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 19 Dec 2019 11:03:50 -0700 Subject: [PATCH 039/331] Delete 'dyn_in' and 'dyn_out' pools, and add fields for total physics tendencies The 'dyn_in' and 'dyn_out' pools were previously added to store the CAM-MPAS dynamics import and export states. However, the preferred approach in CAM is to have the dycore define its import and export states to match as closely as possible the prognostic state of the dycore. To that end, CAM-MPAS will now point to 'u', 'w', 'rho_zz', 'theta_m', 'scalars', and fields holding the total tendencies from physics. Since these total tendency fields did not previously exist, they have been added as 'tend_ru_physics', 'tend_rtheta_physics', and 'tend_rho_physics'. These will be referenced by the CAM-MPAS dynamics import state, and they are now used in the atm_srk3 routine in place of what were local, allocatable arrays. --- src/core_atmosphere/Registry.xml | 172 ++---------------- .../dynamics/mpas_atm_time_integration.F | 14 +- 2 files changed, 20 insertions(+), 166 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 29f0cbf137..490ad150da 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2707,9 +2707,20 @@ description="ocean mixed layer integrated v (meridional velocity)"/> +#endif + + + + + + +#ifdef DO_PHYSICS @@ -2808,9 +2819,11 @@ +#endif +#ifdef DO_PHYSICS - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#endif - diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 82c4661aff..014f720d1d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -30,7 +30,7 @@ module atm_time_integration integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables - real (kind=RKIND), allocatable, dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics + real (kind=RKIND), dimension(:,:), pointer :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics ! Used in compute_dyn_tend real (kind=RKIND), allocatable, dimension(:,:) :: qtot @@ -223,6 +223,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) ! ! Retrieve fields @@ -241,11 +242,12 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(qtot(nVertLevels,nCells+1)) qtot(:,nCells+1) = 0.0_RKIND - allocate(tend_rtheta_physics(nVertLevels,nCells+1)) + + call mpas_pool_get_array(tend_physics, 'tend_rtheta_physics', tend_rtheta_physics) tend_rtheta_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_rho_physics(nVertLevels,nCells+1)) + call mpas_pool_get_array(tend_physics, 'tend_rho_physics', tend_rho_physics) tend_rho_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_ru_physics(nVertLevels,nEdges+1)) + call mpas_pool_get_array(tend_physics, 'tend_ru_physics', tend_ru_physics) tend_ru_physics(:,nEdges+1) = 0.0_RKIND ! @@ -1055,9 +1057,7 @@ subroutine atm_srk3(domain, dt, itimestep) deallocate(qtot) ! we are finished with these now - deallocate(tend_rtheta_physics) - deallocate(tend_rho_physics) - deallocate(tend_ru_physics) + ! ! split transport, at present RK3 From 094f5bd6708632dd5e75f4e788d36127a33581c8 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 15 Jan 2020 17:13:29 -0700 Subject: [PATCH 040/331] Make 'postread_reindex' routine public in the mpas_stream_manager module The postread_reindex routine in the mpas_stream_manager module was previously private. However, code that builds ad hoc streams at the mpas_io_streams level that contain indexing fields could benefit from the use of this routine to reindex indexing fields (e.g., cellsOnCell). Unlike the prewrite_reindex and postwrite_reindex routines, which rely on module state, the postread_reindex routine does not rely on any module variables in the mpas_stream_manager module, and can therefore be safely used by external code. --- src/framework/mpas_stream_manager.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index a74c0d643e..21991ac5e6 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -47,6 +47,8 @@ module mpas_stream_manager MPAS_get_stream_filename, & MPAS_build_stream_filename + public :: postread_reindex + private interface MPAS_stream_mgr_set_property From 354c5c30d4781f76254374a7c12d5a5b2782d59b Mon Sep 17 00:00:00 2001 From: Miles A Curry Date: Mon, 20 Jan 2020 17:41:20 +0000 Subject: [PATCH 041/331] Add mpas_stack to init_atmosphere core This commit adds a new module to the MPAS init_atmosphere core, mpas_stack, which is a simple stack implementation. At current, this module is not being used by any part of the init_atmosphere core. --- src/core_init_atmosphere/Makefile | 8 +- src/core_init_atmosphere/mpas_stack.F | 280 ++++++++++++++++++++++++++ 2 files changed, 286 insertions(+), 2 deletions(-) create mode 100644 src/core_init_atmosphere/mpas_stack.F diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index e8f71becfc..9dccef4e35 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -19,7 +19,8 @@ OBJS = \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ mpas_atmphys_initialize_real.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o all: core_hyd @@ -72,11 +73,14 @@ mpas_init_atm_core_interface.o: mpas_init_atm_core.o mpas_init_atm_core.o: mpas_advection.o mpas_init_atm_cases.o +mpas_stack.o: + mpas_init_atm_static.o: \ mpas_atm_advection.o \ mpas_init_atm_hinterp.o \ mpas_init_atm_llxy.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o mpas_init_atm_surface.o: \ mpas_init_atm_hinterp.o \ diff --git a/src/core_init_atmosphere/mpas_stack.F b/src/core_init_atmosphere/mpas_stack.F new file mode 100644 index 0000000000..7227295a9f --- /dev/null +++ b/src/core_init_atmosphere/mpas_stack.F @@ -0,0 +1,280 @@ +module mpas_stack + + implicit none + + private + + ! Public Subroutines and Structures + public :: mpas_stack_is_empty + public :: mpas_stack_push + public :: mpas_stack_pop + public :: mpas_stack_free + + public :: mpas_stack_type, mpas_stack_payload_type + + type mpas_stack_payload_type + end type mpas_stack_payload_type + + type mpas_stack_type + type (mpas_stack_type), pointer :: next => null() + class (mpas_stack_payload_type), pointer :: payload => null() + end type mpas_stack_type + + !*********************************************************************** + ! + ! module mpas_stack + ! + !> \brief MPAS Stack module + !> \author Miles A. Curry + !> \date 04/04/19 + !> \details + !> + !> Introduction + !> ============== + !> The MPAS stack is a simple, extensible data stack data structure for use + !> within the MPAS atmospheric model. It functions as a wrapper around a + !> polymorphic data structure to provide usage in different areas. + !> + !> + !> Creating a Stack + !> ================== + !> The stack data structure (`type (mpas_stack_type)`) is defined by a single + !> `next` pointer > and a pointer to a `type (mpas_stack_payload_type)`, which + !> is defined as a empty derived type. + !> + !> To use the stack, create a derived type that extends the `mpas_stack_payload_type` + !> type. Define your extended derived type with members that meets your application. + !> + !> For instance: + !> ``` + !> type, extends(mpas_stack_payload_type) :: my_payload_name + !> ! Define the members of your type as you wish + !> end type my_payload_name + !> + !> class (my_payload_name), pointer :: item1 => null(), item2 => null() + !> ``` + !> + !> The extended mpas_stack_payload_type will enable a user defined type to be + !> associated with a stack item. The stack stores references of a payload, thus + !> a single payload can be used in multiple push operations. + !> + !> You will then need to create a stack (or multiple stacks if you desire) as + !> the following: + !> + !> ``` + !> type (mpas_stack_type), pointer :: stack1 => null(), stack2 => null() + !> ``` + !> + !> Pushing onto a Stack + !> ==================== + !> You can push your items onto a stack as: + !> + !> ``` + !> allocate(item1) + !> stack1 => mpas_stack_push(stack1, item1) + !> allocate(item2) + !> stack1 => mpas_stack_push(stack1, item2) + !> ``` + !> + !> Popping an item off of the stack + !> ================================ + !> Popping an item off of the stack will require a bit more work than pushing. + !> Because the payload is a polymorphic class , we will need to use the select + !> case to get our type (or multiple types) back into a usable object: + !> ``` + !> ! The item to pop items into + !> class (mpas_stack_payload_type), pointer :: top + !> type (my_payload_name), pointer :: my_item + !> + !> top => mpas_stack_pop(stack1) + !> select type(top) + !> type is(my_payload_name) + !> my_item => top + !> end select + !> ``` + !> + !> Note: It is recommended to create your own `pop` function so you can reduce + !> the amount of coded needed. An example is provided at the bottom of + !> this module as the function `user_pop(..)` + ! + !----------------------------------------------------------------------- + + contains + + !*********************************************************************** + ! + ! routine mpas_stack_is_empty + ! + !> \brief Returns .true. if the stack is empty, otherwise .false. + !> \author Miles A. Curry + !> \date 01/28/20 + !> Returns .true. If the stack is empty and/or if the stack is unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_is_empty(stack) result(is_empty) + + implicit none + type (mpas_stack_type), intent(in), pointer :: stack + logical :: is_empty + + is_empty = .true. + if (associated(stack)) then + is_empty = .false. + return + endif + + end function mpas_stack_is_empty + + !*********************************************************************** + ! + ! routine mpas_stack_push + ! + !> \brief Push an item onto stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> + !> Push a mpas_stack_payload_type type, onto `stack` and return the new stack. If + !> `payload` is the first item to be pushed onto the stack, then `stack` + !> should be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_push(stack, payload) result(new_stack) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + class(mpas_stack_payload_type), intent(inout), target :: payload + + type(mpas_stack_type), pointer :: new_stack + + allocate(new_stack) + new_stack % payload => payload + new_stack % next => stack + + return + + end function mpas_stack_push + + !*********************************************************************** + ! + ! function mpas_stack_pop + ! + !> \brief Pop off the last item added from a stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Pop off and return the top item of the stack as a `class mpas_stack_payload_type`. + !> If the stack is empty (or unassociated), then a null `class mpas_stack_payload_type` + !> pointer will be returned. `select type` will need to be used to retrieve + !> any extended members. + ! + !----------------------------------------------------------------------- + function mpas_stack_pop(stack) result(top) + + implicit none + + type (mpas_stack_type), intent(inout), pointer :: stack + type (mpas_stack_type), pointer :: next => null() + class(mpas_stack_payload_type), pointer :: top + + if ( .not. associated(stack)) then + top => null() + return + endif + + top => stack % payload + next => stack % next + deallocate(stack) + stack => next + return + + end function mpas_stack_pop + + !*********************************************************************** + ! + ! function mpas_stack_free + ! + !> \brief Deallocate the entire stack. Optionally deallocate payloads + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate the entire stack. If free_payload is set to `.true.` or if + !> absent then the payload will be deallocated. If not, then the payload will not + !> be deallocated. Upon success, the stack will be unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_stack_free(stack, free_payload) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + logical, intent(in), optional :: free_payload + logical :: fpl + + type(mpas_stack_type), pointer :: cur + + if (present(free_payload)) then + fpl = free_payload + else + fpl = .true. + endif + + cur => stack + do while(associated(stack)) + stack => stack % next + if ( fpl ) then + deallocate(cur % payload) + endif + deallocate(cur) + cur => stack + enddo + + end subroutine mpas_stack_free + + + !*********************************************************************** + ! + ! Example user-defined pop function + ! + !> \brief Pop off the last item added from a stack and return it as our + !> defined type + !> \author Miles A. Curry + !> \date 01/28/20 + ! + !----------------------------------------------------------------------- + ! function user_pop(stack) result(item) + ! + ! use mpas_stack, only : mpas_stack_type, mpas_stack_payload_type, mpas_stack_pop + ! + ! implicit none + ! + ! type(mpas_stack_type), intent(inout), pointer :: stack + ! + ! type(my_item), pointer :: item ! Our user defined mpas_stack_type + ! + ! ! We will need to use the mpas_stack_payload_type type to use mpas_stack_pop(...) + ! class(mpas_stack_payload_type), pointer :: top + ! + ! ! + ! ! Handle a pop on an empty stack if we want to here + ! ! Note the stack will return null if it is empty. + ! ! + ! if (mpas_stack_is_empty(stack)) then + ! item => null() + ! return + ! endif + ! + ! top => mpas_stack_pop(stack) + ! + ! select type(top) + ! type is(my_item) + ! item => top + ! class default + ! write(0,*) "We got an Error and we should handle it if we need to!!" + ! stop + ! end select + ! + ! end function user_pop + +end module mpas_stack From 48ffedef868717150338bd2b14c366c791152580 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 10 Feb 2020 16:45:06 -0700 Subject: [PATCH 042/331] Remove unused arguments scalar_tend and rho_zz_int from atm_advance_scalars Following a comment in the code, the unused arguments scalar_tend and rho_zz_int can be removed from the argument list of atm_advance_scalars. Furthermore, as the actual argument (scalar_tend_array) to scalar_tend was only used in the call to atm_advance_scalars, it can also be removed from the atm_time_integration module. --- .../dynamics/mpas_atm_time_integration.F | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e286ee0f8f..a97fc7ee54 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -54,7 +54,6 @@ module atm_time_integration real (kind=RKIND), dimension(:,:), allocatable :: flux_tmp_arr real (kind=RKIND), dimension(:,:), allocatable :: wdtn_arr real (kind=RKIND), dimension(:,:), allocatable :: rho_zz_int - real (kind=RKIND), dimension(:,:,:), allocatable :: scalar_tend_array real (kind=RKIND), dimension(:,:,:), allocatable :: scalars_driving ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition @@ -1413,8 +1412,6 @@ subroutine atm_srk3(domain, dt, itimestep) wdtn_arr(:,nCells+1) = 0.0_RKIND allocate(rho_zz_int(nVertLevels,nCells+1)) rho_zz_int(:,nCells+1) = 0.0_RKIND - allocate(scalar_tend_array(num_scalars,nVertLevels,nCells+1)) - scalar_tend_array(:,:,nCells+1) = 0.0_RKIND if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND @@ -1431,8 +1428,6 @@ subroutine atm_srk3(domain, dt, itimestep) ! so we use the advance_scalars routine for the first two RK substeps. ! - ! The latest version of atm_advance_scalars does not need the arrays scalar_tend_array or rho_zz_int - ! We can remove scalar_tend_array???? WCS 20160921 !$OMP PARALLEL DO do thread=1,nThreads if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then @@ -1444,7 +1439,7 @@ subroutine atm_srk3(domain, dt, itimestep) vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.true., scalar_tend=scalar_tend_array, rho_zz_int=rho_zz_int ) + advance_density=.true.) else block % domain = domain @@ -1470,7 +1465,6 @@ subroutine atm_srk3(domain, dt, itimestep) deallocate(flux_array) deallocate(wdtn_arr) deallocate(rho_zz_int) - deallocate(scalar_tend_array) if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then deallocate(horiz_flux_array) else @@ -3102,7 +3096,7 @@ end subroutine atm_recover_large_step_variables_work subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nCells, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - horiz_flux_arr, rk_step, config_time_integration_order, advance_density, scalar_tend, rho_zz_int) + horiz_flux_arr, rk_step, config_time_integration_order, advance_density) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Integrate scalar equations - explicit transport plus other tendencies @@ -3127,8 +3121,6 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(:,:,:), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND), dimension(:), pointer :: invAreaCell @@ -3217,7 +3209,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n bdyMaskCell, bdyMaskEdge, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - local_advance_density, scalar_tend, rho_zz_int) + local_advance_density) else call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -3245,7 +3237,7 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm bdyMaskCell, bdyMaskEdge, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - advance_density, scalar_tend, rho_zz_int) + advance_density) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Integrate scalar equations - explicit transport plus other tendencies @@ -3298,8 +3290,6 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 real (kind=RKIND), intent(in) :: coef_3rd_order real (kind=RKIND), dimension(num_scalars,nVertLevels,nEdges+1), intent(inout) :: horiz_flux_arr - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:), intent(in) :: invAreaCell integer, dimension(:), intent(in) :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition integer, intent(in) :: nCellsSolve, nEdges @@ -3335,7 +3325,6 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old ! - ! horizontal flux divergence, accumulate in scalar_tend ! horiz_flux_arr stores the value of the scalar at the edge. From b8765876b029bd55350c79322f3c301caea3bdb0 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 10 Feb 2020 17:06:47 -0700 Subject: [PATCH 043/331] Remove superfluous if-test around call to atm_advance_scalars_work The atm_advance_scalars routine previously had a test on the value of local_advance_density to determine how to call the atm_advance_scalars_work. However, both calls to atm_advance_scalars_work are identical after the changes in the preceding commit, and so the if-test can be eliminated. --- .../dynamics/mpas_atm_time_integration.F | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a97fc7ee54..0135d967ad 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -3198,7 +3198,6 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - if (local_advance_density) then call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3210,19 +3209,6 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) - else - call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - local_advance_density) - end if end subroutine atm_advance_scalars @@ -3758,11 +3744,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end if ! begin with update of density - do iCell=cellStart,cellEnd - rho_zz_int(:,iCell) = 0.0 - end do -!$OMP BARRIER do iCell=cellSolveStart,cellSolveEnd + rho_zz_int(:,iCell) = 0.0 do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) From 7792b7aa8f4fdf910ceb57a3df549b39e9540e5a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 10 Feb 2020 17:52:00 -0700 Subject: [PATCH 044/331] Factor-out scalar transport code from atm_srk3 into a new subroutine There was previously substantial duplicated code to call the atm_advance_scalars and atm_advance_scalars_mono routines from two places in the atm_srk3 routine, depending on the setting of config_split_dynamics_transport. This common code has been moved to a new routine, advance_scalars. --- .../dynamics/mpas_atm_time_integration.F | 414 ++++++++---------- 1 file changed, 183 insertions(+), 231 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 0135d967ad..3f73827998 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -991,119 +991,8 @@ subroutine atm_srk3(domain, dt, itimestep) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if - - ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! -!$OMP PARALLEL DO - do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.false. ) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.false.) - end if - end do -!$OMP END PARALLEL DO - - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if - - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if + call advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport @@ -1362,125 +1251,9 @@ subroutine atm_srk3(domain, dt, itimestep) RK3_SPLIT_TRANSPORT : do rk_step = 1, 3 ! Runge-Kutta loop - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - allocate(rho_zz_int(nVertLevels,nCells+1)) - rho_zz_int(:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if - - ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! - -!$OMP PARALLEL DO - do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.true.) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.true., rho_zz_int=rho_zz_int) - end if - end do -!$OMP END PARALLEL DO - - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - deallocate(rho_zz_int) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if - - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if + call advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport) -!------------------------------------------------------------------------------------------------------------------------ if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport @@ -1790,6 +1563,185 @@ subroutine atm_srk3(domain, dt, itimestep) end subroutine atm_srk3 + !----------------------------------------------------------------------- + ! routine advance_scalars + ! + !> \brief Advance the scalar fields + !> \date 10 February 2020 + !> \details + !> Manages the advance of the model scalar fields, taking into account + !> runtime selection of monotonicity and scalar transport splitting. + ! + !----------------------------------------------------------------------- + subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport) + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, intent(in) :: rk_step + real(kind=RKIND), dimension(:), intent(in) :: rk_timestep + logical, intent(in) :: config_monotonic + logical, intent(in) :: config_positive_definite + integer, intent(in) :: config_time_integration_order + logical, intent(in) :: config_split_dynamics_transport + + ! Local variables + integer :: thread + + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: mesh + + type (block_type), pointer :: block + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nVertices + integer, pointer :: nVertLevels + integer, pointer :: num_scalars + + integer, pointer :: nThreads + integer, dimension(:), pointer :: cellThreadStart + integer, dimension(:), pointer :: cellThreadEnd + integer, dimension(:), pointer :: cellSolveThreadStart + integer, dimension(:), pointer :: cellSolveThreadEnd + integer, dimension(:), pointer :: vertexThreadStart + integer, dimension(:), pointer :: vertexThreadEnd + integer, dimension(:), pointer :: vertexSolveThreadStart + integer, dimension(:), pointer :: vertexSolveThreadEnd + integer, dimension(:), pointer :: edgeThreadStart + integer, dimension(:), pointer :: edgeThreadEnd + integer, dimension(:), pointer :: edgeSolveThreadStart + integer, dimension(:), pointer :: edgeSolveThreadEnd + + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_start('atm_advance_scalars') + else + call mpas_timer_start('atm_advance_scalars_mono') + end if + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + + allocate(scalar_old_arr(nVertLevels,nCells+1)) + scalar_old_arr(:,nCells+1) = 0.0_RKIND + allocate(scalar_new_arr(nVertLevels,nCells+1)) + scalar_new_arr(:,nCells+1) = 0.0_RKIND + allocate(s_max_arr(nVertLevels,nCells+1)) + s_max_arr(:,nCells+1) = 0.0_RKIND + allocate(s_min_arr(nVertLevels,nCells+1)) + s_min_arr(:,nCells+1) = 0.0_RKIND + allocate(scale_array(nVertLevels,2,nCells+1)) + scale_array(:,:,nCells+1) = 0.0_RKIND + allocate(flux_array(nVertLevels,nEdges+1)) + flux_array(:,nEdges+1) = 0.0_RKIND + allocate(wdtn_arr(nVertLevels+1,nCells+1)) + wdtn_arr(:,nCells+1) = 0.0_RKIND + if (config_split_dynamics_transport) then + allocate(rho_zz_int(nVertLevels,nCells+1)) + rho_zz_int(:,nCells+1) = 0.0_RKIND + else + allocate(rho_zz_int(1,1)) + end if + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) + horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND + else + allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) + flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND + allocate(flux_tmp_arr(nVertLevels,nEdges+1)) + flux_tmp_arr(:,nEdges+1) = 0.0_RKIND + end if + + ! + ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses + ! the functionality of the advance_scalars routine; however, it is noticeably slower, + ! so we use the advance_scalars routine for the first two RK substeps. + ! + !$OMP PARALLEL DO + do thread=1,nThreads + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call atm_advance_scalars(tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & + horiz_flux_array, rk_step, config_time_integration_order, & + advance_density=config_split_dynamics_transport) + else + call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & + scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & + scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & + advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) + end if + end do + !$OMP END PARALLEL DO + + deallocate(scalar_old_arr) + deallocate(scalar_new_arr) + deallocate(s_max_arr) + deallocate(s_min_arr) + deallocate(scale_array) + deallocate(flux_array) + deallocate(wdtn_arr) + deallocate(rho_zz_int) + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + deallocate(horiz_flux_array) + else + deallocate(flux_upwind_tmp_arr) + deallocate(flux_tmp_arr) + end if + + block => block % next + end do + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_stop('atm_advance_scalars') + else + call mpas_timer_stop('atm_advance_scalars_mono') + end if + + end subroutine advance_scalars + + subroutine atm_rk_integration_setup( state, diag, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) From 1ec929e91853f61a40717534eefd94ddefaabe9b Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 10 Feb 2020 18:01:32 -0700 Subject: [PATCH 045/331] Remove unused vertex loop bounds from scalar transport routines The atm_advance_scalars and atm_advance_scalars_mono routines never used the vertex loop bound arguments, which have now been removed in order to simplify the code. --- .../dynamics/mpas_atm_time_integration.F | 53 +++++++------------ 1 file changed, 20 insertions(+), 33 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 3f73827998..165c92412e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1608,10 +1608,6 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi integer, dimension(:), pointer :: cellThreadEnd integer, dimension(:), pointer :: cellSolveThreadStart integer, dimension(:), pointer :: cellSolveThreadEnd - integer, dimension(:), pointer :: vertexThreadStart - integer, dimension(:), pointer :: vertexThreadEnd - integer, dimension(:), pointer :: vertexSolveThreadStart - integer, dimension(:), pointer :: vertexSolveThreadEnd integer, dimension(:), pointer :: edgeThreadStart integer, dimension(:), pointer :: edgeThreadEnd integer, dimension(:), pointer :: edgeSolveThreadStart @@ -1643,11 +1639,6 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) @@ -1693,20 +1684,16 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then call atm_advance_scalars(tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & horiz_flux_array, rk_step, config_time_integration_order, & advance_density=config_split_dynamics_transport) else call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & @@ -3046,8 +3033,8 @@ end subroutine atm_recover_large_step_variables_work subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & horiz_flux_arr, rk_step, config_time_integration_order, advance_density) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -3070,8 +3057,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n integer, intent(in) :: rk_step ! rk substep we are integrating integer, intent(in) :: config_time_integration_order ! time integration order real (kind=RKIND) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd logical, intent(in), optional :: advance_density integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 @@ -3151,8 +3138,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & @@ -3166,8 +3153,8 @@ end subroutine atm_advance_scalars subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & @@ -3210,8 +3197,8 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd integer, intent(in) :: rk_step, config_time_integration_order logical, intent(in) :: advance_density real (kind=RKIND), dimension(:,:,:), intent(in) :: scalar_old @@ -3434,8 +3421,8 @@ end subroutine atm_advance_scalars_work subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -3460,8 +3447,8 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe integer, intent(in) :: nEdges ! for allocating stack variables integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn @@ -3523,8 +3510,8 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & coef_3rd_order, nCellsSolve, num_scalars, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & @@ -3537,8 +3524,8 @@ end subroutine atm_advance_scalars_mono subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & coef_3rd_order, nCellsSolve, num_scalars_dummy, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & @@ -3585,8 +3572,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve integer, intent(in) :: nEdges ! for allocating stack variables integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int From 03d0ee31d272256186c2b8adbbe9700f06cfdb57 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 11 Feb 2020 16:15:23 -0700 Subject: [PATCH 046/331] Remove unused variables in scalar transport routines This commit removes unused variables from the scalar transport routines (advance_scalars, atm_advance_scalars, atm_advance_scalars_work, atm_advance_scalars_mono, and atm_advance_scalars_mono_work). This commit also modifies the comment style for transport routines to match the prevailing style in the MPAS framework. --- .../dynamics/mpas_atm_time_integration.F | 274 +++++++++--------- 1 file changed, 131 insertions(+), 143 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 165c92412e..dec76d8dbf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1599,7 +1599,6 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi integer, pointer :: nCells integer, pointer :: nEdges - integer, pointer :: nVertices integer, pointer :: nVertLevels integer, pointer :: num_scalars @@ -1610,8 +1609,6 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi integer, dimension(:), pointer :: cellSolveThreadEnd integer, dimension(:), pointer :: edgeThreadStart integer, dimension(:), pointer :: edgeThreadEnd - integer, dimension(:), pointer :: edgeSolveThreadStart - integer, dimension(:), pointer :: edgeSolveThreadEnd if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then @@ -1641,8 +1638,6 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) allocate(scalar_old_arr(nVertLevels,nCells+1)) scalar_old_arr(:,nCells+1) = 0.0_RKIND @@ -1682,19 +1677,16 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi !$OMP PARALLEL DO do thread=1,nThreads if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars(tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & + call atm_advance_scalars(tend, state, diag, mesh, block % configs, nCells, rk_timestep(rk_step), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & horiz_flux_array, rk_step, config_time_integration_order, & advance_density=config_split_dynamics_transport) else - call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & + call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, nCells, nEdges, rk_timestep(rk_step), & cellThreadStart(thread), cellThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) @@ -3032,17 +3024,21 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end subroutine atm_recover_large_step_variables_work - subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & - horiz_flux_arr, rk_step, config_time_integration_order, advance_density) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - explicit transport plus other tendencies + !----------------------------------------------------------------------- + ! routine atm_advance_scalars ! - ! Wrapper for atm_advance_scalars_work() to de-reference pointers + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars( tend, state, diag, mesh, configs, nCells, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + horiz_flux_arr, rk_step, config_time_integration_order, advance_density) implicit none @@ -3051,26 +3047,19 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: num_scalars ! for allocating stack variables integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step ! rk substep we are integrating integer, intent(in) :: config_time_integration_order ! time integration order real (kind=RKIND) :: dt - integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd logical, intent(in), optional :: advance_density - integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND), dimension(:), pointer :: invAreaCell - real (kind=RKIND) :: rho_zz_new_inv - - real (kind=RKIND) :: scalar_weight real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend_save - real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two - real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg, rho_edge, zgrid, kdiff - real (kind=RKIND), dimension(:), pointer :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg + real (kind=RKIND), dimension(:), pointer :: dvEdge integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:,:,:), intent(inout) :: horiz_flux_arr @@ -3078,10 +3067,9 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n integer, dimension(:), pointer :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension( num_scalars, nVertLevels + 1 ) :: wdtn - integer, pointer :: nCellsSolve, nEdges + integer, pointer :: nEdges - real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw real (kind=RKIND), pointer :: coef_3rd_order integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition @@ -3101,11 +3089,9 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(diag, 'kdiff', kdiff) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) @@ -3113,111 +3099,102 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) - - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) ! regional_MPAS addition call mpas_pool_get_array(mesh, 'fzm', fnm) call mpas_pool_get_array(mesh, 'fzp', fnp) call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & + call atm_advance_scalars_work(nCells, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + scalar_tend_save, fnm, fnp, rdnw, & bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) end subroutine atm_advance_scalars - subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & - cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_work + ! + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars, except + !> it also advances (re-integrates) the density. This re-integration allows the scalar + !> transport routine to use a different timestep than the dry dynamics, and also makes + !> possible a spatial splitting of the scalar transport integration (and density + !> integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in state). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES NOT apply any positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. + ! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_work(nCells, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + scalar_tend_save, fnm, fnp, rdnw, & bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & advance_density) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - explicit transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in state). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES NOT apply any positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use mpas_atm_dimensions implicit none - integer, intent(in) :: num_scalars_dummy ! for allocating stack variables integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd integer, intent(in) :: rk_step, config_time_integration_order logical, intent(in) :: advance_density real (kind=RKIND), dimension(:,:,:), intent(in) :: scalar_old real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalar_new real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalar_tend_save - real (kind=RKIND), dimension(:,:,:), intent(in) :: deriv_two real (kind=RKIND), dimension(:,:), intent(in) :: rho_zz_old - real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_edge, zgrid, rho_zz_new, kdiff - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_zz_new + real (kind=RKIND), dimension(:), intent(in) :: dvEdge integer, dimension(:,:), intent(in) :: cellsOnEdge integer, dimension(:,:), intent(in) :: advCellsForEdge, edgesOnCell integer, dimension(:), intent(in) :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw real (kind=RKIND), intent(in) :: coef_3rd_order real (kind=RKIND), dimension(num_scalars,nVertLevels,nEdges+1), intent(inout) :: horiz_flux_arr real (kind=RKIND), dimension(:), intent(in) :: invAreaCell integer, dimension(:), intent(in) :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition - integer, intent(in) :: nCellsSolve, nEdges + integer, intent(in) :: nEdges integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND) :: rho_zz_new_inv @@ -3420,18 +3397,22 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm end subroutine atm_advance_scalars_work - subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, nVertLevels_dummy, dt, & + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono + ! + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_mono_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. + ! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & + cellSolveStart, cellSolveEnd, & scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - transport plus other tendencies - ! - ! wrapper routine for atm_advance_scalars_mono_work - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use mpas_atm_dimensions @@ -3445,10 +3426,9 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn @@ -3509,10 +3489,10 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition - call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & + call atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & @@ -3523,44 +3503,48 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe end subroutine atm_advance_scalars_mono - subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono_work + ! + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars_mono_work, + !> except it also advances (re-integrates) the density. This re-integration allows + !> the scalar transport routine to use a different timestep than the dry dynamics, + !> and also makes possible a spatial splitting of the scalar transport integration + !> (and density integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in s_new). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES apply positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. + !> + !> The positive-definite or monotonic renormalization is from Zalesak JCP 1979 + !> as used in the RK3 scheme as described in Wang et al MWR 2009 + ! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars_dummy, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & bdyMaskCell, bdyMaskEdge, & advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars_mono_work, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in s_new). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES apply positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - ! The positive-definite or monotonic renormalization is from Zalesak JCP 1979 - ! as used in the RK3 scheme as described in Wang et al MWR 2009 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use mpas_atm_dimensions @@ -3570,10 +3554,9 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve type (mpas_pool_type), intent(inout) :: state integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int @@ -3611,8 +3594,10 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2 - integer, intent(in) :: nCellsSolve, num_scalars_dummy + integer, intent(in) :: nCellsSolve +#ifdef DEBUG_TRANSPORT integer :: icellmax, kmax +#endif real (kind=RKIND), dimension(nVertLevels), intent(in) :: fnm, fnp, rdnw integer, dimension(:), intent(in) :: nEdgesOnCell @@ -3621,7 +3606,10 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels) :: flux_upwind_arr real (kind=RKIND) :: flux3, flux4, flux_upwind - real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3, scmin,scmax + real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 +#ifdef DEBUG_TRANSPORT + real (kind=RKIND) :: scmin,scmax +#endif real (kind=RKIND) :: scale_factor logical :: local_advance_density From 88524850564f023dd64d6989be18ad2328585b23 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Feb 2020 16:45:52 -0700 Subject: [PATCH 047/331] Move queries for nCells, etc., further down scalar transport call stack Prior to this commit, several queries of field dimensions were being made in the advance_scalars routine, and the resulting values passed down through argument lists into the atm_advance_scalars and atm_advance_scalars_mono routines. In an effort to clean up the argument lists, these queries have been moved one level down in the call stacks for the scalar transport. --- .../dynamics/mpas_atm_time_integration.F | 51 +++++++++++-------- 1 file changed, 29 insertions(+), 22 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index dec76d8dbf..467db18941 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1677,13 +1677,13 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi !$OMP PARALLEL DO do thread=1,nThreads if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars(tend, state, diag, mesh, block % configs, nCells, rk_timestep(rk_step), & + call atm_advance_scalars(tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & horiz_flux_array, rk_step, config_time_integration_order, & advance_density=config_split_dynamics_transport) else - call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, nCells, nEdges, rk_timestep(rk_step), & + call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & cellThreadStart(thread), cellThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & @@ -3035,7 +3035,7 @@ end subroutine atm_recover_large_step_variables_work !> to the work routine. ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars( tend, state, diag, mesh, configs, nCells, dt, & + subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & horiz_flux_arr, rk_step, config_time_integration_order, advance_density) @@ -3047,7 +3047,6 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, nCells, dt, & type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: rk_step ! rk substep we are integrating integer, intent(in) :: config_time_integration_order ! time integration order real (kind=RKIND) :: dt @@ -3067,7 +3066,9 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, nCells, dt, & integer, dimension(:), pointer :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign + integer, pointer :: nCells integer, pointer :: nEdges + integer, pointer :: num_scalars real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw real (kind=RKIND), pointer :: coef_3rd_order @@ -3109,12 +3110,14 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, nCells, dt, & call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - call atm_advance_scalars_work(nCells, dt, & + call atm_advance_scalars_work(nCells, num_scalars, dt, & edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & @@ -3157,7 +3160,7 @@ end subroutine atm_advance_scalars !> The transport scheme is from Skamarock and Gassmann MWR 2011. ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars_work(nCells, dt, & + subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & @@ -3169,11 +3172,12 @@ subroutine atm_advance_scalars_work(nCells, dt, & nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & advance_density) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none integer, intent(in) :: nCells ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt integer, intent(in) :: edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd @@ -3408,14 +3412,12 @@ end subroutine atm_advance_scalars_work !> to the work routine. ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, dt, & + subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) - use mpas_atm_dimensions - implicit none type (block_type), intent(inout), target :: block @@ -3424,19 +3426,17 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nEdges ! for allocating stack variables real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn - real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp + real (kind=RKIND), dimension(:,:), intent(inout) :: scalar_old, scalar_new + real (kind=RKIND), dimension(:,:), intent(inout) :: s_max, s_min + real (kind=RKIND), dimension(:,:), intent(inout) :: wdtn + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scale_arr + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_arr + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_upwind_tmp, flux_tmp logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int + real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg @@ -3451,7 +3451,10 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition + integer, pointer :: nCells + integer, pointer :: nEdges integer, pointer :: nCellsSolve + integer, pointer :: num_scalars real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw integer, dimension(:), pointer :: nEdgesOnCell @@ -3459,7 +3462,10 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) @@ -3489,7 +3495,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition - call atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & + call atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & @@ -3535,7 +3541,7 @@ end subroutine atm_advance_scalars_mono !> as used in the RK3 scheme as described in Wang et al MWR 2009 ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & + subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & @@ -3546,7 +3552,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & bdyMaskCell, bdyMaskEdge, & advance_density, rho_zz_int) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none @@ -3554,6 +3560,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, dt, & type (mpas_pool_type), intent(inout) :: state integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nEdges ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd From 62fac884db88eab2dd75657ff174e8c35976bedc Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 14 Feb 2020 15:34:58 -0700 Subject: [PATCH 048/331] Specify name of scalars array in call to advance_scalars(...) The advance_scalars routine now takes as an argument the name of the scalars array to be advected. The assumption is that, if the name of the array is XYZ, then there will exist: (1) An array in the 'state' pool named XYZ with dimensions (num_XYZ, nVertLevels, nCells) and two time levels (2) A dimension, num_XYZ, in the 'state' pool (3) An array in the 'tend' pool named XYZ_tend with dimensions (num_XYZ, nVertLevels, nCells) and one time level The scalars arrays can either be var_arrays formed from multiple constituents, each with dimensions (nVertLevels, nCells), or they can simply be vars with dimensions (num_???, nVertLevels, nCells). --- .../dynamics/mpas_atm_time_integration.F | 91 ++++++++++++------- 1 file changed, 58 insertions(+), 33 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 467db18941..e37bc471bd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -991,7 +991,7 @@ subroutine atm_srk3(domain, dt, itimestep) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - call advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & config_time_integration_order, config_split_dynamics_transport) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport @@ -1251,10 +1251,9 @@ subroutine atm_srk3(domain, dt, itimestep) RK3_SPLIT_TRANSPORT : do rk_step = 1, 3 ! Runge-Kutta loop - call advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & config_time_integration_order, config_split_dynamics_transport) - if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter @@ -1571,14 +1570,31 @@ end subroutine atm_srk3 !> \details !> Manages the advance of the model scalar fields, taking into account !> runtime selection of monotonicity and scalar transport splitting. + !> + !> The first argument, field_name, indicates the base name for the array + !> of scalars to be advected. It is assumed that, if the name of + !> the array is XYZ, then there will exist: + !> + !> (1) An array in the 'state' pool named XYZ with dimensions + !> (num_XYZ, nVertLevels, nCells) and two time levels + !> + !> (2) A dimension, num_XYZ, in the 'state' pool + !> + !> (3) An array in the 'tend' pool named XYZ_tend with dimensions + !> (num_XYZ, nVertLevels, nCells) and one time level + !> + !> The scalars arrays can either be var_arrays formed from multiple + !> constituents, each with dimensions (nVertLevels, nCells), or they can + !> simply be vars with dimensions (num_???, nVertLevels, nCells). ! !----------------------------------------------------------------------- - subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & config_time_integration_order, config_split_dynamics_transport) implicit none ! Arguments + character(len=*), intent(in) :: field_name type (domain_type), intent(inout) :: domain integer, intent(in) :: rk_step real(kind=RKIND), dimension(:), intent(in) :: rk_timestep @@ -1677,19 +1693,19 @@ subroutine advance_scalars(domain, rk_step, rk_timestep, config_monotonic, confi !$OMP PARALLEL DO do thread=1,nThreads if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars(tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=config_split_dynamics_transport) + call atm_advance_scalars(field_name, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + horiz_flux_array, rk_step, config_time_integration_order, & + advance_density=config_split_dynamics_transport) else - call atm_advance_scalars_mono(block, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) + call atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & + scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & + advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) end if end do !$OMP END PARALLEL DO @@ -3035,13 +3051,15 @@ end subroutine atm_recover_large_step_variables_work !> to the work routine. ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & - edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, & - horiz_flux_arr, rk_step, config_time_integration_order, advance_density) + subroutine atm_advance_scalars(field_name, tend, state, diag, mesh, configs, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + horiz_flux_arr, rk_step, config_time_integration_order, advance_density) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag @@ -3054,6 +3072,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & integer, intent(in) :: cellSolveStart, cellSolveEnd logical, intent(in), optional :: advance_density + + ! Local variables real (kind=RKIND), dimension(:), pointer :: invAreaCell real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend_save @@ -3077,6 +3097,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & logical :: local_advance_density + if (present(advance_density)) then local_advance_density = advance_density else @@ -3085,8 +3106,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) - call mpas_pool_get_array(state, 'scalars', scalar_old, 1) - call mpas_pool_get_array(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalar_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalar_new, 2) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) @@ -3099,7 +3120,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend_save) call mpas_pool_get_array(mesh, 'fzm', fnm) call mpas_pool_get_array(mesh, 'fzp', fnp) @@ -3112,7 +3133,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, dt, & call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) @@ -3412,14 +3433,16 @@ end subroutine atm_advance_scalars_work !> to the work routine. ! !----------------------------------------------------------------------- - subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, dt, & - cellStart, cellEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, & - scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & - flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) + subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, configs, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & + flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (block_type), intent(inout), target :: block type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state @@ -3438,6 +3461,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, dt, logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int + ! Local variables real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg real (kind=RKIND), dimension(:), pointer :: dvEdge, invAreaCell @@ -3460,22 +3484,23 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, dt, integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), pointer :: coef_3rd_order + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(state, 'scalars', scalars_old, 1) - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalars_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalars_new, 2) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) From fd6eca93ad2100015e2437c515d6b15d16546248 Mon Sep 17 00:00:00 2001 From: Miles A Curry Date: Tue, 28 Jan 2020 19:08:17 +0000 Subject: [PATCH 049/331] Add a KD-Tree to the init_atmosphere core This commit adds a new module to the MPAS init_atmosphere core, mpas_kd_tree, which contains implementation of a K-Dimensional Tree. At present, the module is not being used by any part of the init_atmosphere core; it is only compiled. --- src/core_init_atmosphere/Makefile | 8 +- src/core_init_atmosphere/mpas_kd_tree.F | 409 ++++++++++++++++++++++++ 2 files changed, 415 insertions(+), 2 deletions(-) create mode 100644 src/core_init_atmosphere/mpas_kd_tree.F diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index e8f71becfc..74b952c563 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -19,7 +19,8 @@ OBJS = \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ mpas_atmphys_initialize_real.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_kd_tree.o all: core_hyd @@ -66,6 +67,8 @@ mpas_init_atm_read_met.o: read_geogrid.o: +mpas_kd_tree.o: + mpas_init_atm_llxy.o: mpas_init_atm_core_interface.o: mpas_init_atm_core.o @@ -76,7 +79,8 @@ mpas_init_atm_static.o: \ mpas_atm_advection.o \ mpas_init_atm_hinterp.o \ mpas_init_atm_llxy.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o\ + mpas_kd_tree.o mpas_init_atm_surface.o: \ mpas_init_atm_hinterp.o \ diff --git a/src/core_init_atmosphere/mpas_kd_tree.F b/src/core_init_atmosphere/mpas_kd_tree.F new file mode 100644 index 0000000000..3770367dcb --- /dev/null +++ b/src/core_init_atmosphere/mpas_kd_tree.F @@ -0,0 +1,409 @@ +module mpas_kd_tree + + !*********************************************************************** + ! + ! module mpas_kd_tree + ! + !> \brief MPAS KD-Tree module + !> \author Miles A. Curry + !> \date 01/28/20 + !> A KD-Tree implementation to create and search perfectly balanced + !> KD-Trees. + !> + !> Use `mpas_kd_type` dervied type to construct points for mpas_kd_construct: + !> + !> real (kind=RKIND), dimension(:,:), allocatable :: array + !> type (mpas_kd_type), pointer :: tree => null() + !> type (mpas_kd_type), dimension(:), pointer :: points => null() + !> + !> allocate(array(k,n)) ! K dims and n points + !> allocate(points(n)) + !> array(:,:) = (/.../) ! Fill array with values + !> + !> do i = 1, n + !> allocate(points(i) % point(k)) ! Allocate point with k dimensions + !> points(i) % point(:) = array(:,i) + !> points(i) % id = i ! Or a value of your choice + !> enddo + !> + !> tree => mpas_kd_construct(points, k) + !> + !> call mpas_kd_free(tree) + !> deallocate(points) + !> deallocate(array) + !> + ! + !----------------------------------------------------------------------- + use mpas_kind_types, only : RKIND + + implicit none + + private + + public :: mpas_kd_type + + ! Public Subroutines + public :: mpas_kd_construct + public :: mpas_kd_search + public :: mpas_kd_free + + type mpas_kd_type + type (mpas_kd_type), pointer :: left => null() + type (mpas_kd_type), pointer :: right => null() + + integer :: split_dim + real (kind=RKIND), dimension(:), pointer :: point => null() + + integer :: id + end type mpas_kd_type + + contains + + !*********************************************************************** + ! + ! recursive routine mpas_kd_construct_internal + ! + !> \brief Create a KD-Tree from a set of k-Dimensional points + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to construct a KD-Tree from an array + !> of mpas_kd_type, points, and return the root of the tree. + !> + !> ndims should be the dimensioned of each individual point found + !> in points and npoints should be the number of points. dim represents + !> the current split dimensioned and is used internally. Upon calling + !> this function, dim should always be set to 0. + ! + !----------------------------------------------------------------------- + recursive function mpas_kd_construct_internal(points, ndims, npoints, dim) result(tree) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:), target :: points + integer, intent(in) :: ndims + integer, value :: npoints + integer, value :: dim + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Variables + integer :: median + + if (npoints < 1) then + tree => null() + return + endif + + ! Sort the points at the split dimension + dim = mod(dim, ndims) + 1 + call quickSort(points, dim, 1, npoints, ndims) + + median = (1 + npoints) / 2 + + points(median) % split_dim = dim + tree => points(median) + + ! Build the right and left sub-trees but do not include the median + ! point (the root of the current tree) + if (npoints /= 1) then + points(median) % left => mpas_kd_construct_internal(points(1:median-1), ndims, median - 1, points(median) % split_dim) + points(median) % right => mpas_kd_construct_internal(points(median+1:npoints), ndims, npoints - median, & + points(median) % split_dim) + endif + + end function mpas_kd_construct_internal + + + !*********************************************************************** + ! + ! routine mpas_kd_construct + ! + !> \brief Construct a balanced KD-Tree + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Create and return a perfectly balanced KD-Tree from an array of + !> mpas_kd_type, points. The point member of every element of the points + !> array should be allocated and set to the points desired to be in the + !> KD-Tree and ndims should be the dimensions of the points. + !> + !> Upon error, the returned tree will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_kd_construct(points, ndims) result(tree) + + implicit none + + ! Input Varaibles + type (mpas_kd_type), dimension(:) :: points + integer, intent(in) :: ndims + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Varaibles + integer :: npoints + + npoints = size(points) + + if (npoints < 1) then + tree => null() + return + endif + + tree => mpas_kd_construct_internal(points(:), ndims, npoints, 0) + + end function mpas_kd_construct + + + !*********************************************************************** + ! + ! recursive routine mpas_kd_search_internal + ! + !> \brief Recursively search the KD-Tree for query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to search kdtree for query. Upon succes + !> res will point to the nearest neighbor to query and distance will hold + !> the squared distance between query and res. + !> + !> Distance is calculated and compared as squared distance to increase + !> efficiency. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_search_internal(kdtree, query, res, distance) + + implicit none + + ! Input Variables + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(inout) :: distance + + ! Local Values + real (kind=RKIND) :: current_distance + + current_distance = sum((kdtree % point(:) - query(:))**2) + if (current_distance < distance) then + distance = current_distance + res => kdtree + endif + + ! + ! To find the nearest neighbor, first serach the tree in a similar manner + ! as a single dimensioned BST, by comparing points on the current split + ! dimension. + ! + ! If the distance between the current node and the query is less then the + ! minimum distance found within the subtree we just searched, then the nearest + ! neighbor might be in the opposite subtree, so search it. + ! + + if (query(kdtree % split_dim) > kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % right)) then ! Search right + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) ! Check the other subtree + endif + else if (query(kdtree % split_dim) < kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % left)) then ! Search left + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) ! Check the other subtree + endif + else ! Nearest point could be in either left or right subtree, so search both + if (associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if (associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + endif + + end subroutine mpas_kd_search_internal + + !*********************************************************************** + ! + ! routine mpas_kd_search + ! + !> \brief Find the nearest point in a KD-Tree to a query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Search kdtree and returned the nearest point to query into the + !> res argument. Optionally, if distance is present, returned the + !> squared distance between query and res. + !> + !> If the dimension of query does not match the dimensions of points + !> within kdtree, then res will be returned as unassociated. Likewise, + !> if kdtree is empty/unassociated, res will be returned as unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_kd_search(kdtree, query, res, distance) + + implicit none + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(out), optional :: distance + + real (kind=RKIND) :: dis + + if (.not. associated(kdtree)) then + res => null() + return + end if + + if (size(kdtree % point) /= size(query)) then + res => null() + return + endif + + dis = huge(dis) + call mpas_kd_search_internal(kdtree, query, res, dis) + + if (present(distance)) then + distance = dis + endif + + end subroutine mpas_kd_search + + !*********************************************************************** + ! + ! routine mpas_kd_free + ! + !> \brief Free all nodes within a tree. + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate and nullify all point nodes of kdtree and nullify the + !> left and right pointers. + !> + !> After calling this function, the array of mpas_kd_type that was used + !> to construct kdtree will still be allocated and will need to be + !> deallocated separate from this routine. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_free(kdtree) + + implicit none + type (mpas_kd_type), pointer :: kdtree + + if (.not. associated(kdtree)) then + return + endif + + if (associated(kdtree % left)) then + call mpas_kd_free(kdtree % left) + endif + + if (associated(kdtree % right)) then + call mpas_kd_free(kdtree % right) + endif + + deallocate(kdtree % point) + nullify(kdtree % left) + nullify(kdtree % right) + nullify(kdtree) + + end subroutine mpas_kd_free + + + !*********************************************************************** + ! + ! routine mpas_kd_quicksort + ! + !> \brief Sort an array along a dimension + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Sort points starting from arrayStart, to arrayEnd along the given dimension + !> `dim`. If two points are swapped, the entire K-Coordinate point are swapped. + ! + !----------------------------------------------------------------------- + recursive subroutine quickSort(array, dim, arrayStart, arrayEnd, ndims) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:) :: array + integer, intent(in), value :: dim + integer, intent(in), value :: arrayStart, arrayEnd + integer, intent(in) :: ndims + + ! Local Variables + type (mpas_kd_type) :: temp + real (kind=RKIND), dimension(ndims) :: pivot_value + + integer :: l, r, pivot, s + + if ((arrayEnd - arrayStart) < 1) then + return + endif + + ! Create the left, right, and start pointers + l = arrayStart + r = arrayEnd - 1 + s = l + + pivot = (l+r)/2 + pivot_value = array(pivot) % point + + ! Move the pivot to the far right + temp = array(pivot) + array(pivot) = array(arrayEnd) + array(arrayEnd) = temp + + do while (.true.) + ! Advance the left pointer until it is a value less then our pivot_value(dim) + do while (.true.) + if (array(l) % point(dim) < pivot_value(dim)) then + l = l + 1 + else + exit + endif + enddo + + ! Advance the right pointer until it is a value more then our pivot_value(dim) + do while (.true.) + if (r <= 0) then + exit + endif + + if(array(r) % point(dim) >= pivot_value(dim)) then + r = r - 1 + else + exit + endif + enddo + + if (l >= r) then + exit + else ! Swap elements about the pivot + temp = array(l) + array(l) = array(r) + array(r) = temp + endif + enddo + + ! Move the pivot to l ended up + temp = array(l) + array(l) = array(arrayEnd) + array(arrayEnd) = temp + + ! Quick Sort on the lower partition + call quickSort(array(:), dim, s, l-1, ndims) + + ! Quick sort on the upper partition + call quickSort(array(:), dim, l+1, arrayEnd, ndims) + + end subroutine quicksort + +end module mpas_kd_tree From 0c250f1ec94fa1ea0695d6f9963b5386f983128c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 2 Mar 2020 17:40:35 -0700 Subject: [PATCH 050/331] Remove unused variables from mpas_atm_core.F This commit removes variables that were reported as unused by the GNU compiler. --- src/core_atmosphere/mpas_atm_core.F | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 5b56d653a8..b7f79d8484 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -36,7 +36,6 @@ function atm_core_init(domain, startTimeStamp) result(ierr) real (kind=RKIND), pointer :: dt type (block_type), pointer :: block - integer :: i logical, pointer :: config_do_restart type (mpas_pool_type), pointer :: state @@ -201,8 +200,8 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) type (mpas_pool_type), intent(inout) :: configs integer, intent(out) :: ierr - type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime - type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + type (MPAS_Time_Type) :: startTime, stopTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep integer :: local_err real (kind=RKIND), pointer :: config_dt character (len=StrKIND), pointer :: config_start_time @@ -288,7 +287,6 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, meshScalingDel4 - real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge real (kind=RKIND), dimension(:), pointer :: areaCell, invAreaCell real (kind=RKIND), dimension(:), pointer :: dvEdge, invDvEdge real (kind=RKIND), dimension(:), pointer :: dcEdge, invDcEdge @@ -504,9 +502,6 @@ function atm_core_run(domain) result(ierr) type (mpas_pool_type), pointer :: state, diag, mesh, diag_physics, tend, tend_physics - ! For high-frequency diagnostics output - character (len=StrKIND) :: tempfilename - ! For timing information real (kind=R8KIND) :: integ_start_time, integ_stop_time real (kind=R8KIND) :: diag_start_time, diag_stop_time @@ -722,9 +717,8 @@ function atm_core_run(domain) result(ierr) block_ptr => domain % blocklist do while (associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - call atm_reset_diagnostics(diag, diag_physics) + call atm_reset_diagnostics(diag_physics) block_ptr => block_ptr % next end do @@ -802,19 +796,17 @@ subroutine atm_compute_output_diagnostics(state, time_lev, diag, mesh) end subroutine atm_compute_output_diagnostics - subroutine atm_reset_diagnostics(diag, diag_physics) + subroutine atm_reset_diagnostics(diag_physics) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! reset some diagnostics after output ! - ! Input: diag - contains dynamics diagnostic fields - ! daig_physics - contains physics diagnostic fields + ! Input: diag_physics - contains physics diagnostic fields ! ! Output: whatever diagnostics need resetting after output !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(inout) :: diag_physics real (kind=RKIND), dimension(:), pointer :: refl10cm_1km_max From 2244845b09ef9d68b2bba9aac90b63fc7451ccd1 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Fri, 6 Mar 2020 20:39:45 +0100 Subject: [PATCH 051/331] Add support for copy_file tag This is needed for copying config files that may then be altered by the user within a test case. Since there is a significant amount of redundant code between this and and support for the `add_link` tag, a helper function has been added to encapsulate the redundancy. Some error messages have been modified to raise exceptions. --- testing_and_setup/compass/setup_testcase.py | 144 +++++++++++--------- 1 file changed, 78 insertions(+), 66 deletions(-) diff --git a/testing_and_setup/compass/setup_testcase.py b/testing_and_setup/compass/setup_testcase.py index d0ed603ed3..a4553301e6 100755 --- a/testing_and_setup/compass/setup_testcase.py +++ b/testing_and_setup/compass/setup_testcase.py @@ -25,6 +25,7 @@ from six.moves import configparser import textwrap import netCDF4 +import shutil try: from collections import defaultdict @@ -1176,61 +1177,7 @@ def add_links(config_file, configs): # {{{ for child in config_root: # Process an tag if child.tag == 'add_link': - try: - source = child.attrib['source'] - except KeyError: - print(" add_link tag missing a 'source' attribute.") - print(" Exiting...") - sys.exit(1) - - try: - source_path_name = child.attrib['source_path'] - - keyword_path = False - if source_path_name.find('work_') >= 0: - keyword_path = True - elif source_path_name.find('script_') >= 0: - keyword_path = True - - if not keyword_path: - if configs.has_option('paths', source_path_name): - source_path = configs.get('paths', source_path_name) - else: - source_path = 'NONE' - - if source_path == 'NONE': - if configs.has_option('script_paths', - source_path_name): - source_path = configs.get('script_paths', - source_path_name) - else: - source_path = 'NONE' - - if source_path == 'NONE': - print("ERROR: source_path on tag is '{}' " - "which is not defined".format(source_path_name)) - print("Exiting...") - sys.exit(1) - - else: - source_arr = source_path_name.split('_') - base_name = source_arr[0] - subname = '{}_{}'.format(source_arr[1], source_arr[2]) - - if base_name == 'work': - file_base_path = 'work_dir' - elif base_name == 'script': - file_base_path = 'script_path' - - if subname in {'core_dir', 'configuration_dir', - 'resolution_dir', 'test_dir', 'case_dir'}: - source_path = '{}/{}'.format( - configs.get('script_paths', file_base_path), - configs.get('script_paths', subname)) - - source_file = '{}/{}'.format(source_path, source) - except KeyError: - source_file = '{}'.format(source) + source_file = get_source_file(child, configs) dest = child.attrib['dest'] old_cwd = os.getcwd() @@ -1240,32 +1187,95 @@ def add_links(config_file, configs): # {{{ '{}'.format(dest)], stdout=dev_null, stderr=dev_null) os.chdir(old_cwd) - del source - del dest # Process an tag elif child.tag == 'add_executable': source_attr = child.attrib['source'] dest = child.attrib['dest'] if not configs.has_option("executables", source_attr): - print('ERROR: Configuration {} requires a definition of ' + raise ValueError('Configuration {} requires a definition of ' '{}.'.format(config_file, source_attr)) - sys.exit(1) - else: - source = configs.get("executables", source_attr) + source = configs.get("executables", source_attr) subprocess.check_call(['ln', '-sf', '{}'.format(source), '{}/{}'.format(base_path, dest)], stdout=dev_null, stderr=dev_null) - del source_attr - del source - del dest - del config_tree - del config_root dev_null.close() # }}} +def get_source_file(child, config): # {{{ + try: + source = child.attrib['source'] + except KeyError: + raise KeyError("{} tag missing a 'source' attribute.".format( + child.tag)) + + try: + source_path_name = child.attrib['source_path'] + except KeyError: + return source + + keyword_path = any(substring in source_path_name for + substring in ['work_', 'script_']) + + if keyword_path: + source_arr = source_path_name.split('_') + base_name = source_arr[0] + if base_name == 'work': + file_base_path = 'work_dir' + elif base_name == 'script': + file_base_path = 'script_path' + else: + raise ValueError('Unexpected source prefix {} in {} tag'.format( + base_name, child.tag)) + + subname = '{}_{}'.format(source_arr[1], source_arr[2]) + if subname not in ['core_dir', 'configuration_dir', + 'resolution_dir', 'test_dir', 'case_dir']: + raise ValueError('Unexpected source suffix {} in {} tag'.format( + subname, child.tag)) + + source_path = '{}/{}'.format( + config.get('script_paths', file_base_path), + config.get('script_paths', subname)) + else: + if config.has_option('paths', source_path_name): + source_path = config.get('paths', source_path_name) + else: + if not config.has_option('script_paths', source_path_name): + raise ValueError('Undefined source_path on {} tag: {}'.format( + child.tag, source_path_name)) + source_path = config.get('script_paths', source_path_name) + + source_file = '{}/{}'.format(source_path, source) + return source_file +# }}} + + +def copy_files(config_file, config): # {{{ + config_tree = ET.parse(config_file) + config_root = config_tree.getroot() + + case = config_root.attrib['case'] + + # Determine the path for the case directory + test_path = '{}/{}'.format(config.get('script_paths', 'test_dir'), case) + base_path = '{}/{}'.format(config.get('script_paths', 'work_dir'), + test_path) + + # Process all children tags + for child in config_root: + # Process an tag + if child.tag == 'copy_file': + source = get_source_file(child, config) + + dest = '{}/{}'.format(base_path, child.attrib['dest']) + + shutil.copy(source, dest) +# }}} + + def make_case_dir(config_file, base_path): # {{{ config_tree = ET.parse(config_file) config_root = config_tree.getroot() @@ -1765,6 +1775,8 @@ def get_case_name(config_file): # {{{ # Process all links for this case add_links(config_file, config) + copy_files(config_file, config) + # Generate run scripts for this case. generate_run_scripts(config_file, '{}'.format(case_path), config) From 9b85b4ad3935ab09bbdd16906e49b699a793cfa1 Mon Sep 17 00:00:00 2001 From: Miles A Curry Date: Thu, 27 Feb 2020 18:46:05 +0000 Subject: [PATCH 052/331] Add ability to parse index files of static data sets This commit creates a new module, mpas_parse_geoindex, which can parse index files that describe static data sets. The index files and data sets are the same data sets that are used by WRF and the WPS. For more information on valid fields for an index file please see section 3-53 "Description of Index Options" of the WRF Users Guide. The mpas_parse_geoindex is currently not used by any portion of the init_atmosphere core; it is only compiled. --- src/core_init_atmosphere/Makefile | 8 +- .../mpas_parse_geoindex.F | 263 ++++++++++++++++++ 2 files changed, 269 insertions(+), 2 deletions(-) create mode 100644 src/core_init_atmosphere/mpas_parse_geoindex.F diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index 9dccef4e35..c270e587f7 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -20,7 +20,8 @@ OBJS = \ mpas_atmphys_functions.o \ mpas_atmphys_initialize_real.o \ mpas_atmphys_utilities.o \ - mpas_stack.o + mpas_stack.o \ + mpas_parse_geoindex.o all: core_hyd @@ -75,12 +76,15 @@ mpas_init_atm_core.o: mpas_advection.o mpas_init_atm_cases.o mpas_stack.o: +mpas_parse_geoindex.o: + mpas_init_atm_static.o: \ mpas_atm_advection.o \ mpas_init_atm_hinterp.o \ mpas_init_atm_llxy.o \ mpas_atmphys_utilities.o \ - mpas_stack.o + mpas_stack.o \ + mpas_parse_geoindex.o mpas_init_atm_surface.o: \ mpas_init_atm_hinterp.o \ diff --git a/src/core_init_atmosphere/mpas_parse_geoindex.F b/src/core_init_atmosphere/mpas_parse_geoindex.F new file mode 100644 index 0000000000..eef129b2db --- /dev/null +++ b/src/core_init_atmosphere/mpas_parse_geoindex.F @@ -0,0 +1,263 @@ +module mpas_parse_geoindex + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_LOG_WARN + use mpas_pool_routines + + implicit none + + private + + public :: mpas_parse_index + + contains + + !*********************************************************************** + ! + ! subroutine mpas_parse_index + ! + !> \brief Parse a geogrid's index file and put the results into an MPAS pool + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Parse an index file of a static data set into an MPAS pool, allocating + !> each keyword=value pair into the pool with the pool member key being + !> keyword, and the value being value. + !> + !> This function can parse index files with one keyword=value pair + !> per line; a "#" at the start of a line, which will cause the line to be + !> ignored; or an empty line containing only a newline/return character, which + !> will also be ignored. Spaces or tabs before, between or after the + !> keyword=value tokens are > ignored. + !> + !> If a line contains anything but the above valid syntaxes, a syntax + !> error will raised and -1 will be returned. + !> + !> Case is ignored. + !> + !> The definitions of a keyword, which can found in section 3-53 + !> of the WRF-AWR User's Guide, will determine the corresponding type + !> of that keyword. A keyword that has been assigned the wrong type + !> will raise a type error and -1 will be returned. + !> + !> Keywords that are not handled explicitly by this function will produce + !> a warning that the keyword is unrecognized. + ! + !----------------------------------------------------------------------- + function mpas_parse_index(path, geo_pool) result(ierr) + + use mpas_io_units + + implicit none + ! Input Variables + character (len=*), intent(in) :: path + type (mpas_pool_type), intent(inout) :: geo_pool + integer :: ierr + + ! Local Variables + character (len=StrKIND) :: line, lhs, rhs + character (len=StrKIND) :: read_err_msg, open_msg + integer :: geo_unit + integer :: open_stat, read_stat, line_read_stat + integer :: i, k + logical :: res + + character (len=StrKIND), pointer :: char_t + integer :: iceiling, ifloor + integer, pointer :: int_t + real(kind=RKIND), pointer :: real_t + + ierr = 0 + + inquire(file=trim(path), exist=res) + if ( .not. res) then + call mpas_log_write("Could not find or open the file at: "//trim(path), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_new_unit(geo_unit) + open_stat = 0 + open(geo_unit, FILE=trim(path), action='READ', iostat=open_stat, iomsg=open_msg) + if (open_stat /= 0) then + call mpas_release_unit(geo_unit) + call mpas_log_write("Could not open 'index' file at:'"//trim(path)//"'", messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(open_msg), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + line_read_stat = 0 + read_stat = 0 + k = 1 ! Keep track of line numbers for error reporting + read(geo_unit,'(a)', iostat=line_read_stat) line + do while ( line_read_stat == 0 ) + line = lowercase(line) + + ! + ! If a blank or comment line is encountered, read the next line + ! + if (line(1:1) == '#' .or. len_trim(line) == 0) then + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + cycle + endif + + do i = 1, len(trim(line)), 1 + if (line(i:i) == '=') then + lhs = adjustl(trim(line(1:i-1))) + rhs = adjustl(trim(line(i+1:len(trim(line))))) + exit + endif + ! If i is at the end of the string, and we haven't broken out of this loop, + ! then we do not have a '=' present in this line, thus we have a syntax error + if (i == len(trim(line))) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Syntax error on line $i of index file: '"//trim(path)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write("Line $i: '"//trim(line)//"'", intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + enddo + + ! + ! Strings + ! + if ( trim(lhs) == 'type' & + .or. trim(lhs) == 'projection' & + .or. trim(lhs) == 'units' & + .or. trim(lhs) == 'description' & + .or. trim(lhs) == 'row_order' & + .or. trim(lhs) == 'endian' & + .or. trim(lhs) == 'mminlu' ) then + + allocate(char_t) + char_t = rhs + call mpas_pool_add_config(geo_pool, trim(lhs), char_t) + + ! + ! Reals + ! + else if ( trim(lhs) == 'dx' & + .or. trim(lhs) == 'dy' & + .or. trim(lhs) == 'known_x' & + .or. trim(lhs) == 'known_y' & + .or. trim(lhs) == 'known_lat' & + .or. trim(lhs) == 'known_lon' & + .or. trim(lhs) == 'scale_factor' & + .or. trim(lhs) == 'stdlon' & + .or. trim(lhs) == 'truelat1' & + .or. trim(lhs) == 'truelat2' & + .or. trim(lhs) == 'missing_value' ) then + + allocate(real_t) + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + call mpas_pool_add_config(geo_pool, trim(lhs), real_t) + + ! + ! Integers + ! + else if ( trim(lhs) == 'tile_x' & + .or. trim(lhs) == 'tile_y' & + .or. trim(lhs) == 'tile_z' & + .or. trim(lhs) == 'tile_z_start' & + .or. trim(lhs) == 'tile_z_end' & + .or. trim(lhs) == 'tile_bdr' & + .or. trim(lhs) == 'wordsize' & + .or. trim(lhs) == 'category_max' & + .or. trim(lhs) == 'category_min' & + .or. trim(lhs) == 'iswater' & + .or. trim(lhs) == 'islake' & + .or. trim(lhs) == 'isice' & + .or. trim(lhs) == 'isurban' & + .or. trim(lhs) == 'isoilwater' & + .or. trim(lhs) == 'filename_digits' ) then + + ! Because each compiler handles reporting type errors when transferring + ! data in a read statement a little bit differently, we will have to type check + ! integer values ourselves. + allocate(real_t) + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + iceiling = ceiling(real_t) + ifloor = floor(real_t) + if (iceiling /= ifloor) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error while reading '"//trim(path)//"'.", messageType=MPAS_LOG_ERR) + call mpas_log_write("Could not convert '"//trim(rhs)//"' to an integer on line $i: '"//trim(line)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + allocate(int_t) + int_t = int(real_t) + deallocate(real_t) + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + + ! + ! Booleans - Yes will be assigned 1, and no will be assigned to 0 + ! + else if (lhs == 'signed') then + if (trim(rhs) == 'yes') then + allocate(int_t) + int_t = 1 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else if (trim(rhs) == 'no') then + allocate(int_t) + int_t = 0 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else + read_stat = -1 + read_err_msg = "Logical was not correct type" + endif + else + call mpas_log_write("Unrecognized keyword: '"//trim(lhs)//"' on line $i of '"//trim(path)//"'", intArgs=(/k/), & + messageType=MPAS_LOG_WARN) + endif + ! Since read gives us an error string in iomsg on a type error, we + ! can handle all errors for any type in one place + if ( read_stat /= 0) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error on line $i of: '"//trim(path)//"'.", intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(read_err_msg)//": '"//trim(line)//"'", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + enddo + + close(geo_unit) + call mpas_release_unit(geo_unit) + + end function mpas_parse_index + + + ! Returns a copy of 'str' in which all upper-case letters have been converted + ! to lower-case letters. + function lowercase(str) result(lowerStr) + + character(len=*), intent(in) :: str + character(len=len(str)) :: lowerStr + + integer :: i + integer, parameter :: offset = (iachar('a') - iachar('A')) + + + do i=1,len(str) + if (iachar(str(i:i)) >= iachar('A') .and. iachar(str(i:i)) <= iachar('Z')) then + lowerStr(i:i) = achar(iachar(str(i:i)) + offset) + else + lowerStr(i:i) = str(i:i) + end if + end do + + end function lowercase + + +end module mpas_parse_geoindex From 89ae5bbce6f16edb5607b275bb7bb879408779aa Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 9 Apr 2020 11:24:45 -0600 Subject: [PATCH 053/331] Add scratch arrays in tend_physics pool for zonal and meridional wind tendencies In order to allow future code to avoid having to create ad hoc fields to udpate halos of cell-centered wind tendencies as we currently do in tend_toEdges, this commit adds two scratch arrays, tend_uzonal and tend_umerid, to the tend_physics pool. At present, these scratch arrays are not actually used. --- src/core_atmosphere/Registry.xml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..6681aa9a30 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2688,6 +2688,15 @@ + + + + + From 95f910728ac99f2fb4fc36a9ac0e05b455315462 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 9 Apr 2020 13:44:47 -0600 Subject: [PATCH 054/331] Do not zero-out physics tendencies if MPAS_CAM_DYCORE is defined Previously, if DO_PHYSICS was not defined, the fields tend_rtheta_physics, tend_ru_physics, and tend_rho_physics were set to zero in the solver at the point where the physics_get_tend routine would have been called. In CAM-MPAS, although we do not use stand-alone MPAS-A physics, we do want to use the tendencies from CAM physics. Accordingly, the physics tendencies are now only zeroed-out if neither DO_PHYSICS nor MPAS_CAM_DYCORE are defined. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 014f720d1d..c9ce2c230e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -420,12 +420,14 @@ subroutine atm_srk3(domain, dt, itimestep) end do call mpas_timer_stop('physics_get_tend') #else +#ifndef MPAS_CAM_DYCORE ! ! If no physics are being used, simply zero-out the physics tendency fields ! tend_ru_physics(:,:) = 0.0_RKIND tend_rtheta_physics(:,:) = 0.0_RKIND tend_rho_physics(:,:) = 0.0_RKIND +#endif #endif ! From 9842866e0f084f5326dab3d5cfb8fff585ed3f80 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 20 Apr 2020 16:46:23 -0600 Subject: [PATCH 055/331] Use RKIND kind type parameter for real constants defined in mpas_constants The real-valued parameters in the mpas_constants module were previously set to literal values without an explicit kind type parameter. This may lead to differences in simulation results depending on whether MPAS is compiled with flags to promote the default real kind (e.g, -fdefault-real-8 with the GNU Fortran compiler). For example, if RKIND is defined as 8, the 'gravity' constant defined below will take on different values, depending on whether MPAS is compiled with, e.g., -fdefault-real-8 (using the GNU compiler) or not: real (kind=RKIND), parameter :: gravity = 9.80616 The correct way to initialize real-valued parameters with kind-type RKIND is to explicitly specify the kind type parameter for the literal value: real (kind=RKIND), parameter :: gravity = 9.80616_RKIND --- src/framework/mpas_constants.F | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 1eec5d3565..c76ddb6eb9 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -22,18 +22,18 @@ module mpas_constants use mpas_kind_types - real (kind=RKIND), parameter :: pii = 3.141592653589793 !< Constant: Pi - real (kind=RKIND), parameter :: a = 6371229.0 !< Constant: Spherical Earth radius [m] - real (kind=RKIND), parameter :: omega = 7.29212e-5 !< Constant: Angular rotation rate of the Earth [s-1] - real (kind=RKIND), parameter :: gravity = 9.80616 !< Constant: Acceleration due to gravity [m s-2] - real (kind=RKIND), parameter :: rgas = 287.0 !< Constant: Gas constant for dry air [J kg-1 K-1] - real (kind=RKIND), parameter :: rv = 461.6 !< Constant: Gas constant for water vapor [J kg-1 K-1] - real (kind=RKIND), parameter :: rvord = rv/rgas ! -! real (kind=RKIND), parameter :: cp = 1003.0 !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cp = 7.*rgas/2. !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] - real (kind=RKIND), parameter :: cvpm = -cv/cp ! - real (kind=RKIND), parameter :: prandtl = 1.0 !< Constant: Prandtl number + real (kind=RKIND), parameter :: pii = 3.141592653589793_RKIND !< Constant: Pi + real (kind=RKIND), parameter :: a = 6371229.0_RKIND !< Constant: Spherical Earth radius [m] + real (kind=RKIND), parameter :: omega = 7.29212e-5_RKIND !< Constant: Angular rotation rate of the Earth [s-1] + real (kind=RKIND), parameter :: gravity = 9.80616_RKIND !< Constant: Acceleration due to gravity [m s-2] + real (kind=RKIND), parameter :: rgas = 287.0_RKIND !< Constant: Gas constant for dry air [J kg-1 K-1] + real (kind=RKIND), parameter :: rv = 461.6_RKIND !< Constant: Gas constant for water vapor [J kg-1 K-1] + real (kind=RKIND), parameter :: rvord = rv / rgas ! +! real (kind=RKIND), parameter :: cp = 1003.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: cp = 7.0_RKIND*rgas/2.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] + real (kind=RKIND), parameter :: cvpm = -cv / cp ! + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number contains From 0d60e7cb2d4f28f60827522c790200c3d7657ee3 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Thu, 12 Mar 2020 15:39:28 +0100 Subject: [PATCH 056/331] Add Travis CI and bare-bones docs The docs are mostly focused on COMPASS with stub for ocean design docs. Also adds CI for testing that the compass conda package can be installed and that it can run the 4 basic COMPASS scripts --- .travis.yml | 54 ++ docs/Makefile | 20 + docs/compass/clean_testcase.rst | 37 + docs/compass/config.rst | 303 ++++++++ docs/compass/details.rst | 12 + docs/compass/driver_script.rst | 159 +++++ docs/compass/index.rst | 46 ++ docs/compass/list_testcases.rst | 44 ++ docs/compass/manage_regression_suite.rst | 48 ++ docs/compass/ocean.rst | 56 ++ .../ocean_testcases/baroclinic_channel.rst | 6 + docs/compass/ocean_testcases/global_ocean.rst | 6 + docs/compass/ocean_testcases/index.rst | 11 + docs/compass/ocean_testcases/isomip_plus.rst | 16 + .../ocean_testcases/isomip_plus_at_lanl.rst | 658 ++++++++++++++++++ docs/compass/regression_suite.rst | 53 ++ docs/compass/run_config.rst | 85 +++ docs/compass/scripts.rst | 12 + docs/compass/setup_testcase.rst | 57 ++ docs/compass/template.rst | 137 ++++ docs/conf.py | 182 +++++ docs/index.rst | 24 + docs/ocean/design_docs/index.rst | 9 + docs/ocean/index.rst | 7 + travis_ci/get_docs_version.bash | 18 + travis_ci/install_compass.bash | 6 + travis_ci/install_docs.bash | 18 + travis_ci/test_compass.bash | 14 + travis_ci/test_docs.bash | 41 ++ 29 files changed, 2139 insertions(+) create mode 100644 .travis.yml create mode 100644 docs/Makefile create mode 100644 docs/compass/clean_testcase.rst create mode 100644 docs/compass/config.rst create mode 100644 docs/compass/details.rst create mode 100644 docs/compass/driver_script.rst create mode 100644 docs/compass/index.rst create mode 100644 docs/compass/list_testcases.rst create mode 100644 docs/compass/manage_regression_suite.rst create mode 100644 docs/compass/ocean.rst create mode 100644 docs/compass/ocean_testcases/baroclinic_channel.rst create mode 100644 docs/compass/ocean_testcases/global_ocean.rst create mode 100644 docs/compass/ocean_testcases/index.rst create mode 100644 docs/compass/ocean_testcases/isomip_plus.rst create mode 100644 docs/compass/ocean_testcases/isomip_plus_at_lanl.rst create mode 100644 docs/compass/regression_suite.rst create mode 100644 docs/compass/run_config.rst create mode 100644 docs/compass/scripts.rst create mode 100644 docs/compass/setup_testcase.rst create mode 100644 docs/compass/template.rst create mode 100644 docs/conf.py create mode 100644 docs/index.rst create mode 100644 docs/ocean/design_docs/index.rst create mode 100644 docs/ocean/index.rst create mode 100755 travis_ci/get_docs_version.bash create mode 100755 travis_ci/install_compass.bash create mode 100755 travis_ci/install_docs.bash create mode 100755 travis_ci/test_compass.bash create mode 100755 travis_ci/test_docs.bash diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..a6e61f8cd8 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,54 @@ +# Based on https://github.com/NOAA-ORR-ERD/gridded/blob/master/.travis.yml +language: minimal + +sudo: false + +notifications: + email: false + +# safelist +branches: + only: + - master + - develop + - ocean/develop + - ocean/coastal + - landice/devleop + +jobs: + include: + - name: "docs" + - name: "compass" + # Add new jobs, along with the corresponding travis_ci/install_.bash + # and travis_ci/test_.bash + #- name: "atmosphere" + #- name: "landice" + #- name: "ocean" + #- name: "seaice" +# The following is not needed now but could be added as the "safelist" and +# job list evolves +# exclude: +# - +# name: "compass" +# if: branch == seaice/develop OR branch == e3sm/develop + +env: + global: + secure: "Ckovv5psUv9pdBVaNjsgrk0hXGJbNTi5dzLSWsNQA3Ub4hUXvzgBvX1TgS+CZvq3fkJnxV6SYZIlOkrCqqxdlUzFewDiuzzYxEZObFZ8FceWiYs4K3LMS30MPLzIYaV9ORqXJ0/P/ii62KhGIraX7ryzZ5+IG5uDOd7gumD6GiCPURFQIGpWS7MasKmEQRnokrGO3B2JjGEB0vMTdMZGbj8XY+X4Q0zcdQnjrLtG7PiuED95CrfEI7HfJ/ifPRgI4EMey6YI89DUF6hdQ1N1QxyAnxlKBDkqCvy6uowej7xPwMMZsyykr6EoAcwk9kYluVRogKe1iBMq1P4WCOOUj3c3Q9Dp885TiXlsW1aDKT2RSkx/SV5cE73vrpUhmm2Nf/wWAZktOYJSGlmRqSnjkQhDJqQSOaIQbwBfUtuGMt0Go0Q/3/qlMc7I9AjG5yBuYcY8WN98qKABP3IKjSsIFUPyo1kXCHt++oV7z1p9oBdGS54e+9rEYWixvAwvw0GvrNrbQdiq2sq8BheI4ppzeSGoneHguNDn5QyVeMu4WZ0gsCwuVW0lXiuUSlYHG5ZctX1cQySCyL3IOcpYa1a1/DKINpkwr/Z7T8oOM+UHnXDK96UJfbaG5n5+JZOfWJ6N/Em7weKuwnRiobGQfDqlyEtc1hgcLfvMnkpikENKhss=" + +before_install: + - | + wget https://repo.anaconda.com/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh + bash miniconda.sh -b -p $HOME/miniconda + source $HOME/miniconda/etc/profile.d/conda.sh + conda activate base + conda config --set always_yes yes --set changeps1 no --set show_channel_urls true + conda update conda + conda config --add channels conda-forge --force + conda config --set channel_priority strict + +install: + - ./travis_ci/install_${TRAVIS_JOB_NAME}.bash + +script: + - ./travis_ci/test_${TRAVIS_JOB_NAME}.bash diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000000..19e1d4f711 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line. +SPHINXOPTS = +SPHINXBUILD = sphinx-build +SPHINXPROJ = mpas_model +SOURCEDIR = . +BUILDDIR = _build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/docs/compass/clean_testcase.rst b/docs/compass/clean_testcase.rst new file mode 100644 index 0000000000..3dbbe5f06b --- /dev/null +++ b/docs/compass/clean_testcase.rst @@ -0,0 +1,37 @@ +.. _compass_clean_testcase: + +clean\_testcase.py +================== + +This script is used to clean one or more test cases that have already been +setup. + +It will remove directories and driver scripts that were generated as part of +setting up a test case. + +Command-line options:: + + $ ./clean_testcase.py -h + usage: clean_testcase.py [-h] [-o CORE] [-c CONFIG] [-r RES] [-t TEST] + [-n NUM] [-q] [-a] [--work_dir PATH] + + This script is used to clean one or more test cases that have already been + setup. + + It will remove directories / driver scripts that were generated as part of + setting up a test case. + + optional arguments: + -h, --help show this help message and exit + -o CORE, --core CORE Core that contains configurations to clean + -c CONFIG, --configuration CONFIG + Configuration to clean + -r RES, --resolution RES + Resolution of configuration to clean + -t TEST, --test TEST Test name within a resolution to clean + -n NUM, --case_number NUM + Case number to clean, as listed from list_testcases.py. Can be a comma delimited list of case numbers. + -q, --quiet If set, script will not write a command_history file + -a, --all Is set, the script will clean all test cases in the work_dir. + --work_dir PATH If set, script will clean case directories in work_dir rather than the current directory. + diff --git a/docs/compass/config.rst b/docs/compass/config.rst new file mode 100644 index 0000000000..ab4e624f21 --- /dev/null +++ b/docs/compass/config.rst @@ -0,0 +1,303 @@ +.. _compass_config: + +config +====== + +A config file is used to setup a case directory. +This file contains information describing how to configure a case +directory, including files that the case depends on, executables that are +required for the case, namelists and streams files the case requires, and run +scripts which can be used to automate running a case. + +How to use pre-defined paths +---------------------------- + +This testing infrastructure has several predefined paths available as +attributes to several XML tags. Attributes that can use these will have the +line "Can use pre-defined paths" in their description. + +In order to help you make use of these pre-defined paths, this section will +describe what they are, and how to use them. + +To begin, there are two standard paths. These are referred to as ```` +and ````. + + - ```` is the location where the test cases are setup to run. + - ```` is the location where the testing infrastructure scripts live. + +Additionally, there are 4 sub-paths: + + - ```` - This is the core directory that contains the test case + - ```` - This is the configuration directory that contains the test case + - ```` - This is the resolution directory that contains the test case + - ```` - This is the test directory that contains the test case + - ```` - This is the case directory that is generated from an XML config file + +Now, all attributes that can use pre-defined paths can build a path using the +following syntax:: + + {base}_{sub} + +Where ``{base}`` can be either ``work`` or ``script``, and ``{sub}`` can be any of +``core_dir``, ``configuration_dir``, ``resolution_dir``, ``test_dir``, and ``case_dir``. + +Note however, ``case_dir`` isn't valid when {base} is ``script`` as a case +directory isn't typically generated in the script path if it's different from +the work path. + +As an example: + + - ``script_test_dir`` would point to the location that the XML files exist to + setup a testcase + - ``work_test_dir`` would point to the location that the testcase will be setup, + and will not include the case directory created from an XML file. + + +Description of XML file +----------------------- + +Below, you will see text describing the various XML tags available in a config +file. Each will describe the tag itself, any attributes the tag can have, and +what children can be placed below the tag. + +```` - This is the overarching parent tag of a config file that describes the setup for a case. + + - Attributes: + * ``case``: The name of the case directory that will be created from this + config tag. + + - Children: + * ```` + + * ```` + + * ```` + + * ```` + + * ```` + + * ```` + +```` - This tag defines the need for ensuring a required file is available, and the +appropriate ways of acquiring the file. + + - Attributes: + * ``hash``: (Optional) The expected hash of the mesh file. The acquired + mesh file will be validated using this. If this attribute is omitted, + the resulting file will not be validated. + + * ``dest_path``: The path the resulting file should be placed in. Should be + the name of a path defined in the config file, or optionally 'case' + which is expanded to be the case directory generated from the XML + file containing the get_file tag. Can additionally take the values of + pre-defined paths + + * ``file_name``: The name of the file that will be downloaded and placed in dest_path. + + - Children: + * ```` + +```` - This tag defined the different methods of acquiring a required file. + + - Attributes: + * ``protocol``: A description of how the mesh should be retrieved. + Currently supports ``wget``. + + * ``url``: Only used if ``protocol == wget``. The url (pre-filename) portion of + the ``wget`` command. + +```` - This tag defined the need to link an executable defined in a +configuration file (e.g. general.config) into a case directory. + + - Attributes: + * ``source``: The name of the executable, defined in the configuration file + (e.g. ``general.config``). This name is a short name, and will be + expanded to executables.source + + * ``dest``: The name of the link that will be generated from the executable. + +```` - This tag defined the need to link a file into a case directory. + + - Attributes: + * ``source_path``: The path variable from a configure file to find the + source file in. If it is empty, source is assumed to + have the full path to the file. Additionally, it can + take the values of: + + - Can use pre-defined paths + + * ``source``: The source to generate a symlink from. Relative to the case + directory that will be generated from the parent ```` tag. + + * ``dest``: The name of the resulting symlink. + +```` - This tag defines a namelist that should be generated from a template. + + - Attributes: + * ``name``: The name of the namelist file that will be generated from the + template namelist pointed to by its mode attribute. + + * ``mode``: The name of the mode to use from the template input files + Each core can define these arbitrarily + + - Children: + * ``