From 9d0f897b0827fcfef8ecd564d03237eb27d14247 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Fri, 6 Sep 2024 15:15:02 -0400 Subject: [PATCH 01/13] test harness for window code using external fortran-testanything model_mod.f90 is in the work directory. This is a lazy move to avoid fiddling with EXTRA in quickbuild.sh for issue #718 --- .gitignore | 1 + developer_tests/window/test_window.f90 | 50 +++ developer_tests/window/work/input.nml | 15 + developer_tests/window/work/quickbuild.sh | 40 +++ .../window/work/threed_model_mod.f90 | 298 ++++++++++++++++++ 5 files changed, 404 insertions(+) create mode 100644 developer_tests/window/test_window.f90 create mode 100644 developer_tests/window/work/input.nml create mode 100755 developer_tests/window/work/quickbuild.sh create mode 100644 developer_tests/window/work/threed_model_mod.f90 diff --git a/.gitignore b/.gitignore index b8f113f92..7221ff4cb 100644 --- a/.gitignore +++ b/.gitignore @@ -200,6 +200,7 @@ test_quad_reg_interp test_table_read test_ran_unif test_kde_dist +test_window # Directories to NOT IGNORE ... same as executable names # as far as I know, these must be listed after the executables diff --git a/developer_tests/window/test_window.f90 b/developer_tests/window/test_window.f90 new file mode 100644 index 000000000..b910d8b69 --- /dev/null +++ b/developer_tests/window/test_window.f90 @@ -0,0 +1,50 @@ +program test_window + +use mpi_utilities_mod, only : initialize_mpi_utilities, finalize_mpi_utilities, my_task_id, task_count, task_sync + +use ensemble_manager_mod, only : init_ensemble_manager, end_ensemble_manager, ensemble_type, set_num_extra_copies +use distributed_state_mod, only : create_state_window, free_state_window, get_state +use types_mod, only : i8, r8 + +use test ! fortran-testanything + +implicit none + +integer :: num_copies = 10 +integer :: real_ens_members = 3 +real(r8) :: res(3) +integer(i8) :: num_vars = 201 +type(ensemble_type) :: ens_handle + +call initialize_mpi_utilities('test_window') + +if (my_task_id() == 0 ) then + call plan(3*task_count()) +endif + +call init_ensemble_manager(ens_handle, num_copies, num_vars) +call set_num_extra_copies(ens_handle, num_copies - real_ens_members) + +ens_handle%copies(1:real_ens_members,:) = my_task_id() +ens_handle%copies(real_ens_members+1:num_copies,:) = -100 + +call create_state_window(ens_handle) + +! result should be index-1 mod task_count() for round robin distribution +res = get_state(1_i8, ens_handle) +call ok(res(1) == mod(1-1, task_count())) + +res = get_state(27_i8, ens_handle) +call ok(res(1) == mod(27-1, task_count())) + +res = get_state(198_i8, ens_handle) +call ok(res(1) == mod(198-1, task_count())) + +call free_state_window(ens_handle) + +call end_ensemble_manager(ens_handle) + +call finalize_mpi_utilities() + + +end program test_window \ No newline at end of file diff --git a/developer_tests/window/work/input.nml b/developer_tests/window/work/input.nml new file mode 100644 index 000000000..71e9d827f --- /dev/null +++ b/developer_tests/window/work/input.nml @@ -0,0 +1,15 @@ +&ensemble_manager_nml +/ + +&utilities_nml + module_details = .false. + / + +&preprocess_nml + input_obs_qty_mod_file = '../../../assimilation_code/modules/observations/DEFAULT_obs_kind_mod.F90' + output_obs_qty_mod_file = '../../../assimilation_code/modules/observations/obs_kind_mod.f90' + input_obs_def_mod_file = '../../../observations/forward_operators/DEFAULT_obs_def_mod.F90' + output_obs_def_mod_file = '../../../observations/forward_operators/obs_def_mod.f90' + obs_type_files = '../../../observations/forward_operators/obs_def_gps_mod.f90' + quantity_files = '../../../assimilation_code/modules/observations/default_quantities_mod.f90' + / diff --git a/developer_tests/window/work/quickbuild.sh b/developer_tests/window/work/quickbuild.sh new file mode 100755 index 000000000..a9165534a --- /dev/null +++ b/developer_tests/window/work/quickbuild.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash + +# DART software - Copyright UCAR. This open source software is provided +# by UCAR, "as is", without charge, subject to all terms of use at +# http://www.image.ucar.edu/DAReS/DART/DART_download + +main() { + + +export DART=$(git rev-parse --show-toplevel) +source "$DART"/build_templates/buildfunctions.sh + +MODEL="none" +EXTRA=/Users/hkershaw/DART/issues/fortran-testanything +dev_test=1 +LOCATION="threed_sphere" +TEST="window" + +programs=( +test_window +) + +# quickbuild arguments +arguments "$@" + +# clean the directory +\rm -f -- *.o *.mod Makefile .cppdefs + +# build and run preprocess before making any other DART executables +buildpreprocess + +# build DART +buildit + +# clean up +\rm -f -- *.o *.mod + +} + +main "$@" diff --git a/developer_tests/window/work/threed_model_mod.f90 b/developer_tests/window/work/threed_model_mod.f90 new file mode 100644 index 000000000..07976db5d --- /dev/null +++ b/developer_tests/window/work/threed_model_mod.f90 @@ -0,0 +1,298 @@ +! DART software - Copyright UCAR. This open source software is provided +! by UCAR, "as is", without charge, subject to all terms of use at +! http://www.image.ucar.edu/DAReS/DART/DART_download +! + +module model_mod + +! This is a template showing the interfaces required for a model to be compliant +! with the DART data assimilation infrastructure. Do not change the arguments +! for the public routines. + +use types_mod, only : r8, i8, MISSING_R8 + +use time_manager_mod, only : time_type, set_time + +use location_mod, only : location_type, get_close_type, & + loc_get_close_obs => get_close_obs, & + loc_get_close_state => get_close_state, & + set_location, set_location_missing + +use utilities_mod, only : error_handler, & + E_ERR, E_MSG, & + nmlfileunit, do_output, do_nml_file, do_nml_term, & + find_namelist_in_file, check_namelist_read + +use netcdf_utilities_mod, only : nc_add_global_attribute, nc_synchronize_file, & + nc_add_global_creation_time, & + nc_begin_define_mode, nc_end_define_mode + +use state_structure_mod, only : add_domain, get_domain_size + +use ensemble_manager_mod, only : ensemble_type + +! These routines are passed through from default_model_mod. +! To write model specific versions of these routines +! remove the routine from this use statement and add your code to +! this the file. +use default_model_mod, only : pert_model_copies, read_model_time, write_model_time, & + init_time => fail_init_time, & + init_conditions => fail_init_conditions, & + convert_vertical_obs, convert_vertical_state, adv_1step + +implicit none +private + +! routines required by DART code - will be called from filter and other +! DART executables. +public :: get_model_size, & + get_state_meta_data, & + model_interpolate, & + end_model, & + static_init_model, & + nc_write_model_atts, & + get_close_obs, & + get_close_state, & + pert_model_copies, & + convert_vertical_obs, & + convert_vertical_state, & + read_model_time, & + adv_1step, & + init_time, & + init_conditions, & + shortest_time_between_assimilations, & + write_model_time + + +character(len=256), parameter :: source = "model_mod.f90" +logical :: module_initialized = .false. +integer :: dom_id ! used to access the state structure +type(time_type) :: assimilation_time_step + +! Example Namelist +! Use the namelist for options to be set at runtime. +character(len=256) :: template_file = 'model_restart.nc' +integer :: time_step_days = 0 +integer :: time_step_seconds = 3600 + +namelist /model_nml/ template_file, time_step_days, time_step_seconds + +contains + +!------------------------------------------------------------------ +! +! Called to do one time initialization of the model. As examples, +! might define information about the model size or model timestep. +! In models that require pre-computed static data, for instance +! spherical harmonic weights, these would also be computed here. + +subroutine static_init_model() + +integer :: iunit, io + +module_initialized = .true. + +call find_namelist_in_file("input.nml", "model_nml", iunit) +read(iunit, nml = model_nml, iostat = io) +call check_namelist_read(iunit, io, "model_nml") + +! Record the namelist values used for the run +if (do_nml_file()) write(nmlfileunit, nml=model_nml) +if (do_nml_term()) write( * , nml=model_nml) + +! This time is both the minimum time you can ask the model to advance +! (for models that can be advanced by filter) and it sets the assimilation +! window. All observations within +/- 1/2 this interval from the current +! model time will be assimilated. If this is not settable at runtime +! feel free to hardcode it and remove from the namelist. +assimilation_time_step = set_time(time_step_seconds, & + time_step_days) + + +! Define which variables are in the model state +dom_id = add_domain(template_file, num_vars=2, var_names=(/'Temp', 'Wind'/)) + +end subroutine static_init_model + +!------------------------------------------------------------------ +! Returns the number of items in the state vector as an integer. + +function get_model_size() + +integer(i8) :: get_model_size + +if ( .not. module_initialized ) call static_init_model + +get_model_size = get_domain_size(dom_id) + +end function get_model_size + + +!------------------------------------------------------------------ +! Given a state handle, a location, and a state quantity, +! interpolates the state variable fields to that location and returns +! the values in expected_obs. The istatus variables should be returned as +! 0 unless there is some problem in computing the interpolation in +! which case a positive istatus should be returned. +! +! For applications in which only perfect model experiments +! with identity observations (i.e. only the value of a particular +! state variable is observed), this can be a NULL INTERFACE. + +subroutine model_interpolate(state_handle, ens_size, location, qty, expected_obs, istatus) + + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +type(location_type), intent(in) :: location +integer, intent(in) :: qty +real(r8), intent(out) :: expected_obs(ens_size) !< array of interpolated values +integer, intent(out) :: istatus(ens_size) + +if ( .not. module_initialized ) call static_init_model + +! This should be the result of the interpolation of a +! given kind (itype) of variable at the given location. +expected_obs(:) = MISSING_R8 + +! istatus for successful return should be 0. +! Any positive number is an error. +! Negative values are reserved for use by the DART framework. +! Using distinct positive values for different types of errors can be +! useful in diagnosing problems. +istatus(:) = 1 + +end subroutine model_interpolate + + + +!------------------------------------------------------------------ +! Returns the smallest increment in time that the model is capable +! of advancing the state in a given implementation, or the shortest +! time you want the model to advance between assimilations. + +function shortest_time_between_assimilations() + +type(time_type) :: shortest_time_between_assimilations + +if ( .not. module_initialized ) call static_init_model + +shortest_time_between_assimilations = assimilation_time_step + +end function shortest_time_between_assimilations + + + +!------------------------------------------------------------------ +! Given an integer index into the state vector, returns the +! associated location and optionally the physical quantity. + +subroutine get_state_meta_data(index_in, location, qty) + +integer(i8), intent(in) :: index_in +type(location_type), intent(out) :: location +integer, intent(out), optional :: qty + + +if ( .not. module_initialized ) call static_init_model + +! should be set to the actual location using set_location() +location = set_location_missing() + +! should be set to the physical quantity, e.g. QTY_TEMPERATURE +if (present(qty)) qty = 0 + +end subroutine get_state_meta_data + + +!------------------------------------------------------------------ +! Any model specific distance calcualtion can be done here +subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + +type(get_close_type), intent(in) :: gc ! handle to a get_close structure +integer, intent(in) :: base_type ! observation TYPE +type(location_type), intent(inout) :: base_loc ! location of interest +type(location_type), intent(inout) :: locs(:) ! obs locations +integer, intent(in) :: loc_qtys(:) ! QTYS for obs +integer, intent(in) :: loc_types(:) ! TYPES for obs +integer, intent(out) :: num_close ! how many are close +integer, intent(out) :: close_ind(:) ! incidies into the locs array +real(r8), optional, intent(out) :: dist(:) ! distances in radians +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_obs' + +call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + +end subroutine get_close_obs + + +!------------------------------------------------------------------ +! Any model specific distance calcualtion can be done here +subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + +type(get_close_type), intent(in) :: gc ! handle to a get_close structure +type(location_type), intent(inout) :: base_loc ! location of interest +integer, intent(in) :: base_type ! observation TYPE +type(location_type), intent(inout) :: locs(:) ! state locations +integer, intent(in) :: loc_qtys(:) ! QTYs for state +integer(i8), intent(in) :: loc_indx(:) ! indices into DART state vector +integer, intent(out) :: num_close ! how many are close +integer, intent(out) :: close_ind(:) ! indices into the locs array +real(r8), optional, intent(out) :: dist(:) ! distances in radians +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_state' + + +call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + + +end subroutine get_close_state + + +!------------------------------------------------------------------ +! Does any shutdown and clean-up needed for model. Can be a NULL +! INTERFACE if the model has no need to clean up storage, etc. + +subroutine end_model() + + +end subroutine end_model + + +!------------------------------------------------------------------ +! write any additional attributes to the output and diagnostic files + +subroutine nc_write_model_atts(ncid, domain_id) + +integer, intent(in) :: ncid ! netCDF file identifier +integer, intent(in) :: domain_id + +if ( .not. module_initialized ) call static_init_model + +! put file into define mode. + +call nc_begin_define_mode(ncid) + +call nc_add_global_creation_time(ncid) + +call nc_add_global_attribute(ncid, "model_source", source ) +call nc_add_global_attribute(ncid, "model", "template") + +call nc_end_define_mode(ncid) + +! Flush the buffer and leave netCDF file open +call nc_synchronize_file(ncid) + +end subroutine nc_write_model_atts + +!=================================================================== +! End of model_mod +!=================================================================== +end module model_mod + From 7d46effe84dadc0dd6388712e136594e7a934482 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Fri, 6 Sep 2024 16:54:08 -0400 Subject: [PATCH 02/13] feat: window without a copy of the data mpi version with all of %copies in the window mpif08 version with all of %copies in the window null_mpi_utilities_mod.f90 version with matchin arguments to the mpi version (does nothing) fixes #718 --- .../utilities/distributed_state_mod.f90 | 2 +- .../modules/utilities/mpi_utilities_mod.f90 | 7 ++++--- .../utilities/mpif08_utilities_mod.f90 | 7 ++++--- .../modules/utilities/no_cray_win_mod.f90 | 19 ++++--------------- .../modules/utilities/no_cray_winf08_mod.f90 | 19 ++++--------------- .../utilities/null_mpi_utilities_mod.f90 | 7 ++++--- 6 files changed, 21 insertions(+), 40 deletions(-) diff --git a/assimilation_code/modules/utilities/distributed_state_mod.f90 b/assimilation_code/modules/utilities/distributed_state_mod.f90 index 340afa151..9038bc3f7 100644 --- a/assimilation_code/modules/utilities/distributed_state_mod.f90 +++ b/assimilation_code/modules/utilities/distributed_state_mod.f90 @@ -110,7 +110,7 @@ subroutine get_fwd(x, my_index, state_ens_handle) !x = get_local_state(element_index) x = state_ens_handle%copies(1:data_count, element_index) else - call get_from_fwd(owner_of_state, state_win, element_index, data_count, x) + call get_from_fwd(owner_of_state, state_win, element_index, state_ens_handle%num_copies, data_count, x) endif endif diff --git a/assimilation_code/modules/utilities/mpi_utilities_mod.f90 b/assimilation_code/modules/utilities/mpi_utilities_mod.f90 index 90797018e..78d0009ed 100644 --- a/assimilation_code/modules/utilities/mpi_utilities_mod.f90 +++ b/assimilation_code/modules/utilities/mpi_utilities_mod.f90 @@ -1968,12 +1968,13 @@ end subroutine get_from_mean !----------------------------------------------------------------------------- -subroutine get_from_fwd(owner, window, mindex, num_rows, x) +subroutine get_from_fwd(owner, window, mindex, rows_in_window, num_rows, x) integer, intent(in) :: owner ! task in the window that owns the memory integer, intent(in) :: window ! window object integer, intent(in) :: mindex ! index in the tasks memory -integer, intent(in) :: num_rows ! number of rows in the window +integer, intent(in) :: rows_in_window ! number of rows in the window +integer, intent(in) :: num_rows ! number of rows to get from the window real(r8), intent(out) :: x(:) ! result integer(KIND=MPI_ADDRESS_KIND) :: target_disp @@ -1983,7 +1984,7 @@ subroutine get_from_fwd(owner, window, mindex, num_rows, x) ! to have occured until the call to mpi_win_unlock. ! => Don't do anything with x in between mpi_get and mpi_win_lock -target_disp = (mindex - 1)*num_rows +target_disp = (mindex - 1)*rows_in_window call mpi_win_lock(MPI_LOCK_SHARED, owner, 0, window, errcode) call mpi_get(x, num_rows, datasize, owner, target_disp, num_rows, datasize, window, errcode) call mpi_win_unlock(owner, window, errcode) diff --git a/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 b/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 index dee8c618d..45d628fa4 100644 --- a/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 +++ b/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 @@ -1969,12 +1969,13 @@ end subroutine get_from_mean !----------------------------------------------------------------------------- -subroutine get_from_fwd(owner, window, mindex, num_rows, x) +subroutine get_from_fwd(owner, window, mindex, rows_in_window, num_rows, x) integer, intent(in) :: owner ! task in the window that owns the memory type(MPI_Win), intent(in) :: window ! window object integer, intent(in) :: mindex ! index in the tasks memory -integer, intent(in) :: num_rows ! number of rows in the window +integer, intent(in) :: rows_in_window ! number of rows in the window +integer, intent(in) :: num_rows ! number of rows to get from the window real(r8), intent(out) :: x(num_rows) ! result integer(KIND=MPI_ADDRESS_KIND) :: target_disp @@ -1984,7 +1985,7 @@ subroutine get_from_fwd(owner, window, mindex, num_rows, x) ! to have occured until the call to mpi_win_unlock. ! => Don't do anything with x in between mpi_get and mpi_win_lock -target_disp = (mindex - 1)*num_rows +target_disp = (mindex - 1)*rows_in_window call mpi_win_lock(MPI_LOCK_SHARED, owner, 0, window, errcode) call mpi_get(x, num_rows, datasize, owner, target_disp, num_rows, datasize, window, errcode) call mpi_win_unlock(owner, window, errcode) diff --git a/assimilation_code/modules/utilities/no_cray_win_mod.f90 b/assimilation_code/modules/utilities/no_cray_win_mod.f90 index 6090621f8..a81a41114 100644 --- a/assimilation_code/modules/utilities/no_cray_win_mod.f90 +++ b/assimilation_code/modules/utilities/no_cray_win_mod.f90 @@ -2,7 +2,6 @@ ! by UCAR, "as is", without charge, subject to all terms of use at ! http://www.image.ucar.edu/DAReS/DART/DART_download -!> Window without cray pointer. Should you point the window at contigous memory? module window_mod !> \defgroup window window_mod @@ -36,15 +35,12 @@ module window_mod integer, parameter :: MEAN_WINDOW = 0 integer, parameter :: STATE_WINDOW = 2 -integer :: data_count !! number of copies in the window +integer :: data_count !! number of copies required integer(KIND=MPI_ADDRESS_KIND) :: window_size logical :: use_distributed_mean = .false. ! initialize to false ! Global memory to stick the mpi window to. ! Need a simply contiguous piece of memory to pass to mpi_win_create -! Openmpi 1.10.0 will not compile with ifort 16 if -! you create a window with a 2d array. -real(r8), allocatable :: contiguous_fwd(:) real(r8), allocatable :: mean_1d(:) type(ensemble_type) :: mean_ens_handle @@ -65,8 +61,7 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl integer :: bytesize !< size in bytes of each element in the window integer :: my_num_vars !< my number of vars -! Find out how many copies to put in the window -! copies_in_window is not necessarily equal to ens_handle%num_copies +! Find out how many copies to get, maybe different to %num_copies data_count = copies_in_window(state_ens_handle) if (get_allow_transpose(state_ens_handle)) then @@ -82,20 +77,15 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl my_num_vars = state_ens_handle%my_num_vars call mpi_type_size(datasize, bytesize, ierr) - window_size = my_num_vars*data_count*bytesize - - allocate(contiguous_fwd(data_count*my_num_vars)) - contiguous_fwd = reshape(state_ens_handle%copies(1:data_count, :), (/my_num_vars*data_count/)) + window_size = my_num_vars*state_ens_handle%num_copies*bytesize ! Expose local memory to RMA operation by other processes in a communicator. - call mpi_win_create(contiguous_fwd, window_size, bytesize, MPI_INFO_NULL, get_dart_mpi_comm(), state_win, ierr) + call mpi_win_create(state_ens_handle%copies, window_size, bytesize, MPI_INFO_NULL, get_dart_mpi_comm(), state_win, ierr) endif ! Set the current window to the state window current_win = STATE_WINDOW -data_count = copies_in_window(state_ens_handle) - end subroutine create_state_window !------------------------------------------------------------- @@ -163,7 +153,6 @@ subroutine free_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handle) else ! close mpi window call mpi_win_free(state_win, ierr) - deallocate(contiguous_fwd) endif current_win = NO_WINDOW diff --git a/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 b/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 index 7ecfd9083..755e8c90b 100644 --- a/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 +++ b/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 @@ -2,7 +2,6 @@ ! by UCAR, "as is", without charge, subject to all terms of use at ! http://www.image.ucar.edu/DAReS/DART/DART_download -!> Window without cray pointer. Should you point the window at contigous memory? module window_mod !> \defgroup window window_mod @@ -36,15 +35,12 @@ module window_mod integer, parameter :: MEAN_WINDOW = 0 integer, parameter :: STATE_WINDOW = 2 -integer :: data_count !! number of copies in the window +integer :: data_count !! number of copies required integer(KIND=MPI_ADDRESS_KIND) :: window_size logical :: use_distributed_mean = .false. ! initialize to false ! Global memory to stick the mpi window to. ! Need a simply contiguous piece of memory to pass to mpi_win_create -! Openmpi 1.10.0 will not compile with ifort 16 if -! you create a window with a 2d array. -real(r8), allocatable :: contiguous_fwd(:) real(r8), allocatable :: mean_1d(:) type(ensemble_type) :: mean_ens_handle @@ -65,8 +61,7 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl integer :: bytesize !< size in bytes of each element in the window integer :: my_num_vars !< my number of vars -! Find out how many copies to put in the window -! copies_in_window is not necessarily equal to ens_handle%num_copies +! Find out how many copies to get, maybe different to %num_copies data_count = copies_in_window(state_ens_handle) if (get_allow_transpose(state_ens_handle)) then @@ -82,20 +77,15 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl my_num_vars = state_ens_handle%my_num_vars call mpi_type_size(datasize, bytesize, ierr) - window_size = my_num_vars*data_count*bytesize - - allocate(contiguous_fwd(data_count*my_num_vars)) - contiguous_fwd = reshape(state_ens_handle%copies(1:data_count, :), (/my_num_vars*data_count/)) + window_size = my_num_vars*state_ens_handle%num_copies*bytesize ! Expose local memory to RMA operation by other processes in a communicator. - call mpi_win_create(contiguous_fwd, window_size, bytesize, MPI_INFO_NULL, get_dart_mpi_comm(), state_win, ierr) + call mpi_win_create(state_ens_handle%copies, window_size, bytesize, MPI_INFO_NULL, get_dart_mpi_comm(), state_win, ierr) endif ! Set the current window to the state window current_win = STATE_WINDOW -data_count = copies_in_window(state_ens_handle) - end subroutine create_state_window !------------------------------------------------------------- @@ -163,7 +153,6 @@ subroutine free_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handle) else ! close mpi window call mpi_win_free(state_win, ierr) - deallocate(contiguous_fwd) endif current_win = NO_WINDOW diff --git a/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 b/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 index cc729c23a..94e2c2088 100644 --- a/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 +++ b/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 @@ -634,13 +634,14 @@ end subroutine get_from_mean !----------------------------------------------------------------------------- -subroutine get_from_fwd(owner, window, mindex, num_rows, x) +subroutine get_from_fwd(owner, window, mindex, rows_in_window, num_rows, x) integer, intent(in) :: owner ! task in the window that owns the memory integer, intent(in) :: window ! window object integer, intent(in) :: mindex ! index in the tasks memory -integer, intent(in) :: num_rows ! number of rows in the window -real(r8), intent(out) :: x(num_rows) ! result +integer, intent(in) :: rows_in_window ! number of rows in the window +integer, intent(in) :: num_rows ! number of rows to get from the window +real(r8), intent(out) :: x(num_rows) ! result call error_handler(E_ERR,'get_from_fwd', 'cannot be used in serial mode', source) From 06a27ec826c96ee5a1ece8b92556be81a6dd0e1d Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Tue, 10 Sep 2024 10:48:30 -0400 Subject: [PATCH 03/13] explicit about length of array since the length is known --- assimilation_code/modules/utilities/mpi_utilities_mod.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/assimilation_code/modules/utilities/mpi_utilities_mod.f90 b/assimilation_code/modules/utilities/mpi_utilities_mod.f90 index 78d0009ed..619d8d1d5 100644 --- a/assimilation_code/modules/utilities/mpi_utilities_mod.f90 +++ b/assimilation_code/modules/utilities/mpi_utilities_mod.f90 @@ -1975,7 +1975,7 @@ subroutine get_from_fwd(owner, window, mindex, rows_in_window, num_rows, x) integer, intent(in) :: mindex ! index in the tasks memory integer, intent(in) :: rows_in_window ! number of rows in the window integer, intent(in) :: num_rows ! number of rows to get from the window -real(r8), intent(out) :: x(:) ! result +real(r8), intent(out) :: x(num_rows) ! result integer(KIND=MPI_ADDRESS_KIND) :: target_disp integer :: errcode From 519cda86a89709f85b243a9de53ac8c1d5d8d27a Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Wed, 11 Sep 2024 10:00:26 -0400 Subject: [PATCH 04/13] remove cray_win_mod The cray window mod was originally added because not all compilers/ mpi implemenations (mpi 2.0) supported mpi windows without using cray pointers. The cray_win_mod has not been compiled into dart for several years, and support for mpi windows has improved (mpi 3.0) --- .../modules/utilities/cray_win_mod.f90 | 219 ------------------ build_templates/buildconvfunctions.sh | 7 +- build_templates/buildfunctions.sh | 8 - 3 files changed, 1 insertion(+), 233 deletions(-) delete mode 100644 assimilation_code/modules/utilities/cray_win_mod.f90 diff --git a/assimilation_code/modules/utilities/cray_win_mod.f90 b/assimilation_code/modules/utilities/cray_win_mod.f90 deleted file mode 100644 index fa04c1284..000000000 --- a/assimilation_code/modules/utilities/cray_win_mod.f90 +++ /dev/null @@ -1,219 +0,0 @@ -! DART software - Copyright UCAR. This open source software is provided -! by UCAR, "as is", without charge, subject to all terms of use at -! http://www.image.ucar.edu/DAReS/DART/DART_download - -!> Contains the window information for the state. Two windows: -!> One for all copies, one for the mean. -!> Not sure whether we should just have one window to avoid multiple synchronizations. - -module window_mod - -!> \defgroup window window_mod -!> @{ -use mpi_utilities_mod, only : datasize, my_task_id -use types_mod, only : r8 -use ensemble_manager_mod, only : ensemble_type, map_pe_to_task, get_var_owner_index, & - copies_in_window, init_ensemble_manager, & - get_allow_transpose, end_ensemble_manager, & - set_num_extra_copies, all_copies_to_all_vars, & - all_vars_to_all_copies - -use mpi - -implicit none - -private -public :: create_mean_window, create_state_window, free_mean_window, & - free_state_window, data_count, mean_win, state_win, current_win, & - mean_ens_handle, NO_WINDOW, MEAN_WINDOW, STATE_WINDOW - -! mpi window handles -integer :: state_win !! window for the forward operator -integer :: mean_win !! window for the mean -integer :: current_win !! keep track of current window, start out assuming an invalid window -!>@todo the number of copies in the window is sloppy. You need to make this better. - -! parameters for keeping track of which window is open -integer, parameter :: NO_WINDOW = -1 -integer, parameter :: MEAN_WINDOW = 0 -integer, parameter :: STATE_WINDOW = 2 - -integer :: data_count !! number of copies in the window -integer(KIND=MPI_ADDRESS_KIND) window_size -logical :: use_distributed_mean = .false. ! initialize to false - -real(r8) :: duplicate_state(*) ! duplicate array for cray pointer fwd -pointer(a, duplicate_state) - -real(r8) :: duplicate_mean(*) ! duplicate array for cray pointer vert convert -pointer(b, duplicate_mean) -type(ensemble_type) :: mean_ens_handle - -contains - -!------------------------------------------------------------- -!> Create the window for the ensemble complete state vector -!> I think you have to pass it the state ensemble handle -subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handle) - -type(ensemble_type), intent(inout) :: state_ens_handle !< state ensemble handle -type(ensemble_type), intent(inout), optional :: fwd_op_ens_handle -type(ensemble_type), intent(inout), optional :: qc_ens_handle - -integer :: ii, jj, count, ierr -integer :: bytesize !< size in bytes of each element in the window -integer :: my_num_vars - -! Find out how many copies to put in the window -! copies_in_window is not necessarily equal to ens_handle%num_copies -data_count = copies_in_window(state_ens_handle) - -if (get_allow_transpose(state_ens_handle)) then - call all_copies_to_all_vars(state_ens_handle) - if (present(fwd_op_ens_handle)) then - call all_copies_to_all_vars(fwd_op_ens_handle) - endif - if (present(qc_ens_handle)) then - call all_copies_to_all_vars(qc_ens_handle) - endif -else - ! find how many variables I have - my_num_vars = state_ens_handle%my_num_vars - - ! allocate some RDMA accessible memory - ! using MPI_ALLOC_MEM because the MPI standard allows vendors to require MPI_ALLOC_MEM for remote memory access - call mpi_type_size(datasize, bytesize, ierr) - window_size = my_num_vars*data_count*bytesize - a = malloc(my_num_vars*data_count) - call MPI_ALLOC_MEM(window_size, MPI_INFO_NULL, a, ierr) - - count = 1 - ! create a duplicate copies array for remote memory access - ! Doing this because you cannot use a cray pointer with an allocatable array - ! Can't do array assignment with a cray pointer, so you need to loop - do ii = 1, my_num_vars - do jj = 1, data_count - duplicate_state(count) = state_ens_handle%copies(jj,ii) - count = count + 1 - enddo - enddo - - ! Expose local memory to RMA operation by other processes in a communicator. - call mpi_win_create(duplicate_state, window_size, bytesize, MPI_INFO_NULL, mpi_comm_world, state_win, ierr) - -endif - -! Set the current window to the state window -current_win = STATE_WINDOW - -data_count = copies_in_window(state_ens_handle) - -end subroutine create_state_window - -!------------------------------------------------------------- -!> Create the window for the ensemble complete state vector -!> I think you have to pass it the state ensemble handle -subroutine create_mean_window(state_ens_handle, mean_copy, distribute_mean) - -type(ensemble_type), intent(in) :: state_ens_handle -integer, intent(in) :: mean_copy -logical, intent(in) :: distribute_mean - -integer :: ii, ierr -integer :: bytesize -integer :: my_num_vars - -! find out how many variables I have -my_num_vars = state_ens_handle%my_num_vars - -! create an ensemble handle of just the mean copy. -use_distributed_mean = distribute_mean - -if (use_distributed_mean) then - - call init_ensemble_manager(mean_ens_handle, 1, state_ens_handle%num_vars) ! distributed ensemble - call set_num_extra_copies(mean_ens_handle, 0) - mean_ens_handle%copies(1,:) = state_ens_handle%copies(mean_copy, :) - - ! find out how many variables I have - my_num_vars = mean_ens_handle%my_num_vars - call mpi_type_size(datasize, bytesize, ierr) - window_size = my_num_vars*bytesize - ! allocate some RDMA accessible memory - ! using MPI_ALLOC_MEM because the MPI standard allows vendors to require MPI_ALLOC_MEM for remote memory access - ! Have a look at MPI-3, I think this removes cray pointers. - b = malloc(my_num_vars) - call MPI_ALLOC_MEM(window_size, MPI_INFO_NULL, b, ierr) - - do ii = 1, my_num_vars - duplicate_mean(ii) = mean_ens_handle%copies(1, ii) - enddo - - ! Expose local memory to RMA operation by other processes in a communicator. - call mpi_win_create(duplicate_mean, window_size, bytesize, MPI_INFO_NULL, mpi_comm_world, mean_win, ierr) - -else - - call init_ensemble_manager(mean_ens_handle, 1, state_ens_handle%num_vars, transpose_type_in = 3) - call set_num_extra_copies(mean_ens_handle, 0) - mean_ens_handle%copies(1,:) = state_ens_handle%copies(mean_copy, :) - call all_copies_to_all_vars(mean_ens_handle) ! this is a transpose-duplicate - -endif - -! Set the current window to the state window -current_win = MEAN_WINDOW - -data_count = copies_in_window(mean_ens_handle) ! One - -end subroutine create_mean_window - -!------------------------------------------------------------- -!> End epoch of state access. -!> Need to transpose qc and fwd operator back to copy complete -subroutine free_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handle) - -type(ensemble_type), intent(inout) :: state_ens_handle -type(ensemble_type), intent(inout), optional :: fwd_op_ens_handle -type(ensemble_type), intent(inout), optional :: qc_ens_handle - -integer :: ierr - -if(get_allow_transpose(state_ens_handle)) then ! the forward operators were done var complete - !transpose back if allowing transposes - if (present(fwd_op_ens_handle)) & - call all_vars_to_all_copies(fwd_op_ens_handle) - if (present(qc_ens_handle)) & - call all_vars_to_all_copies(qc_ens_handle) -else - ! close mpi window - call mpi_win_free(state_win, ierr) - call MPI_FREE_MEM(duplicate_state, ierr) -endif - -current_win = NO_WINDOW - -end subroutine free_state_window - -!--------------------------------------------------------- -!> Free the mpi window -subroutine free_mean_window() - -integer :: ierr - -if(get_allow_transpose(mean_ens_handle)) then - call end_ensemble_manager(mean_ens_handle) -else - call mpi_win_free(mean_win, ierr) - call MPI_FREE_MEM(duplicate_mean, ierr) - call end_ensemble_manager(mean_ens_handle) -endif - -current_win = NO_WINDOW - -end subroutine free_mean_window - -!--------------------------------------------------------- -!> @} -end module window_mod - diff --git a/build_templates/buildconvfunctions.sh b/build_templates/buildconvfunctions.sh index 8b194c7c9..101a04d9f 100644 --- a/build_templates/buildconvfunctions.sh +++ b/build_templates/buildconvfunctions.sh @@ -123,7 +123,6 @@ local mpi="$DART"/assimilation_code/modules/utilities/mpi_utilities_mod.f90 local mpif08="$DART"/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 local nullmpi="$DART"/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 local nullwin="$DART"/assimilation_code/modules/utilities/null_win_mod.f90 -local craywin="$DART"/assimilation_code/modules/utilities/cray_win_mod.f90 local nocraywin="$DART"/assimilation_code/modules/utilities/no_cray_win_mod.f90 local no_cray_winf08="$DART"/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 @@ -133,11 +132,7 @@ if [ "$mpisrc" == "mpi" ]; then core=${core//$nullwin/} core=${core//$mpif08/} core=${core//$no_cray_winf08/} - if [ "$windowsrc" == "craywin" ]; then - core=${core//$nocraywin/} - else #nocraywin - core=${core//$craywin/} - fi + else #nompi core=${core//$mpi/} diff --git a/build_templates/buildfunctions.sh b/build_templates/buildfunctions.sh index f8188a8ca..003d3de78 100644 --- a/build_templates/buildfunctions.sh +++ b/build_templates/buildfunctions.sh @@ -168,7 +168,6 @@ local mpi="$DART"/assimilation_code/modules/utilities/mpi_utilities_mod.f90 local mpif08="$DART"/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 local nullmpi="$DART"/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 local nullwin="$DART"/assimilation_code/modules/utilities/null_win_mod.f90 -local craywin="$DART"/assimilation_code/modules/utilities/cray_win_mod.f90 local nocraywin="$DART"/assimilation_code/modules/utilities/no_cray_win_mod.f90 local no_cray_winf08="$DART"/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 @@ -178,18 +177,12 @@ if [ "$mpisrc" == "mpi" ]; then core=${core//$nullwin/} core=${core//$mpif08/} core=${core//$no_cray_winf08/} - if [ "$windowsrc" == "craywin" ]; then - core=${core//$nocraywin/} - else #nocraywin - core=${core//$craywin/} - fi elif [ "$mpisrc" == "mpif08" ]; then core=${core//$nullmpi/} core=${core//$nullwin/} core=${core//$mpi/} - core=${core//$craywin/} core=${core//$nocraywin/} else #nompi @@ -198,7 +191,6 @@ else #nompi core=${core//$mpif08/} core=${core//$nocraywin/} core=${core//$no_cray_winf08/} - core=${core//$craywin/} fi dartsrc="${core} ${modelsrc} ${loc} ${misc}" From 1a7fc7faa0b96152d79c48bc334aff2e1b5b292d Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Thu, 31 Oct 2024 10:20:46 -0400 Subject: [PATCH 05/13] chore: removed unused routine from normal_distribution_mod.f90 fixes #736 --- .../assimilation/normal_distribution_mod.f90 | 45 ------------------- 1 file changed, 45 deletions(-) diff --git a/assimilation_code/modules/assimilation/normal_distribution_mod.f90 b/assimilation_code/modules/assimilation/normal_distribution_mod.f90 index 6b0656c62..b3a7c3329 100644 --- a/assimilation_code/modules/assimilation/normal_distribution_mod.f90 +++ b/assimilation_code/modules/assimilation/normal_distribution_mod.f90 @@ -493,51 +493,6 @@ subroutine set_normal_params_from_ens(ens, num, p) end subroutine set_normal_params_from_ens -!------------------------------------------------------------------------ -subroutine inv_cdf_quadrature_like(quantiles, ens, likelihood, ens_size, cdf, p, x_out) - -interface - function cdf(x, p) - use types_mod, only : r8 - use distribution_params_mod, only : distribution_params_type - real(r8) :: cdf - real(r8), intent(in) :: x - type(distribution_params_type), intent(in) :: p - end function -end interface - -integer, intent(in) :: ens_size -real(r8), intent(in) :: quantiles(ens_size) -real(r8), intent(in) :: ens(ens_size) -real(r8), intent(in) :: likelihood(ens_size) -type(distribution_params_type), intent(in) :: p -real(r8), intent(out) :: x_out(ens_size) - -integer :: i -real(r8) :: quad_like(ens_size + 1), q_ens(ens_size + 1) - -! Assume that the quantiles and the corresponding ens are sorted - -! Get the likelihood for each of the ens_size + 1 intervals -do i = 2, ens_size - quad_like(i) = (likelihood(i - 1) + likelihood(i)) / 2.0_r8 -end do -quad_like(1) = likelihood(1) -quad_like(ens_size + 1) = likelihood(ens_size) - -! Compute the quantiles at the ensemble boundaries for the posterior -q_ens(1) = quad_like(1) * quantiles(1) -do i = 2, ens_size - q_ens(i) = q_ens(i - 1) + quad_like(i) * (quantiles(i) - quantiles(i - 1)) -end do -q_ens(ens_size + 1) = q_ens(ens_size) + & - quad_like(ens_size + 1) * (1.0_r8 - quantiles(ens_size)) - -! Normalize so that this is a posterior cdf -q_ens = q_ens / q_ens(ens_size + 1) - -end subroutine inv_cdf_quadrature_like - !------------------------------------------------------------------------ end module normal_distribution_mod From f2d98240b59f3a749c59585a82fd5926be375436 Mon Sep 17 00:00:00 2001 From: Marlee Smith Date: Thu, 14 Mar 2024 10:38:54 -0600 Subject: [PATCH 06/13] renaming the window mods as they no longer need to mention cray --- .../modules/utilities/{no_cray_win_mod.f90 => win_mod.f90} | 0 .../modules/utilities/{no_cray_winf08_mod.f90 => winf08_mod.f90} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename assimilation_code/modules/utilities/{no_cray_win_mod.f90 => win_mod.f90} (100%) rename assimilation_code/modules/utilities/{no_cray_winf08_mod.f90 => winf08_mod.f90} (100%) diff --git a/assimilation_code/modules/utilities/no_cray_win_mod.f90 b/assimilation_code/modules/utilities/win_mod.f90 similarity index 100% rename from assimilation_code/modules/utilities/no_cray_win_mod.f90 rename to assimilation_code/modules/utilities/win_mod.f90 diff --git a/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 b/assimilation_code/modules/utilities/winf08_mod.f90 similarity index 100% rename from assimilation_code/modules/utilities/no_cray_winf08_mod.f90 rename to assimilation_code/modules/utilities/winf08_mod.f90 From 6c73b047a635390e06f204fc653f90eaaa0a8f2b Mon Sep 17 00:00:00 2001 From: Marlee Smith Date: Thu, 14 Mar 2024 14:01:46 -0600 Subject: [PATCH 07/13] updating buildfunctions and buildconvfunctions to no longer use the windowsrc variable --- build_templates/buildconvfunctions.sh | 13 +++++-------- build_templates/buildfunctions.sh | 19 ++++++------------- 2 files changed, 11 insertions(+), 21 deletions(-) diff --git a/build_templates/buildconvfunctions.sh b/build_templates/buildconvfunctions.sh index 101a04d9f..91de56d7e 100644 --- a/build_templates/buildconvfunctions.sh +++ b/build_templates/buildconvfunctions.sh @@ -25,7 +25,6 @@ # # The GSI obs converter needs mpi # mpisrc="null_mpi" -# windowsrc="" # m="" #------------------------- set -e @@ -34,7 +33,6 @@ source "$DART"/build_templates/buildpreprocess.sh # Defaults mpisrc="null_mpi" -windowsrc="" m="" LIBRARIES="" EXTRA="" @@ -123,23 +121,22 @@ local mpi="$DART"/assimilation_code/modules/utilities/mpi_utilities_mod.f90 local mpif08="$DART"/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 local nullmpi="$DART"/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 local nullwin="$DART"/assimilation_code/modules/utilities/null_win_mod.f90 -local nocraywin="$DART"/assimilation_code/modules/utilities/no_cray_win_mod.f90 -local no_cray_winf08="$DART"/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 +local win="$DART"/assimilation_code/modules/utilities/win_mod.f90 +local winf08="$DART"/assimilation_code/modules/utilities/winf08_mod.f90 if [ "$mpisrc" == "mpi" ]; then core=${core//$nullmpi/} core=${core//$nullwin/} core=${core//$mpif08/} - core=${core//$no_cray_winf08/} + core=${core//$winf08/} else #nompi core=${core//$mpi/} core=${core//$mpif08/} - core=${core//$nocraywin/} - core=${core//$no_cray_winf08/} - core=${core//$craywin/} + core=${core//$win/} + core=${core//$winf08/} fi convsrc="${core} ${conv} ${obserrsrc} ${modelsrc} ${misc} ${loc}" diff --git a/build_templates/buildfunctions.sh b/build_templates/buildfunctions.sh index 003d3de78..c0973ace2 100644 --- a/build_templates/buildfunctions.sh +++ b/build_templates/buildfunctions.sh @@ -105,7 +105,6 @@ fi # Default to build with mpi (non f08 version) mpisrc=mpi -windowsrc=no_cray_win m="-w" # mkmf wrapper arg # if the first argument is help, nompi, mpi, mpif08, clean @@ -116,20 +115,17 @@ case $1 in nompi) mpisrc="null_mpi" - windowsrc="" m="" shift 1 ;; mpi) mpisrc="mpi" - windowsrc="no_cray_win" shift 1 ;; mpif08) mpisrc="mpif08" - windowsrc="no_cray_winf08" shift 1 ;; @@ -168,29 +164,29 @@ local mpi="$DART"/assimilation_code/modules/utilities/mpi_utilities_mod.f90 local mpif08="$DART"/assimilation_code/modules/utilities/mpif08_utilities_mod.f90 local nullmpi="$DART"/assimilation_code/modules/utilities/null_mpi_utilities_mod.f90 local nullwin="$DART"/assimilation_code/modules/utilities/null_win_mod.f90 -local nocraywin="$DART"/assimilation_code/modules/utilities/no_cray_win_mod.f90 -local no_cray_winf08="$DART"/assimilation_code/modules/utilities/no_cray_winf08_mod.f90 +local win="$DART"/assimilation_code/modules/utilities/win_mod.f90 +local winf08="$DART"/assimilation_code/modules/utilities/winf08_mod.f90 if [ "$mpisrc" == "mpi" ]; then core=${core//$nullmpi/} core=${core//$nullwin/} core=${core//$mpif08/} - core=${core//$no_cray_winf08/} + core=${core//$winf08/} elif [ "$mpisrc" == "mpif08" ]; then core=${core//$nullmpi/} core=${core//$nullwin/} core=${core//$mpi/} - core=${core//$nocraywin/} + core=${core//$win/} else #nompi core=${core//$mpi/} core=${core//$mpif08/} - core=${core//$nocraywin/} - core=${core//$no_cray_winf08/} + core=${core//$win/} + core=${core//$winf08/} fi dartsrc="${core} ${modelsrc} ${loc} ${misc}" @@ -283,7 +279,6 @@ if [ ! -z "$single_prog" ] ; then # build a single program elif [[ " ${serial_programs[*]} " =~ " ${single_prog} " ]]; then echo "building serial dart program " $single_prog mpisrc="null_mpi" - windowsrc="" m="" findsrc dartbuild $single_prog @@ -296,7 +291,6 @@ if [ ! -z "$single_prog" ] ; then # build a single program elif [[ " ${model_serial_programs[*]} " =~ " ${single_prog} " ]];then echo "building model program" $single_prog mpisrc="null_mpi" - windowsrc="" m="" findsrc modelbuild $single_prog @@ -332,7 +326,6 @@ done [ $mpisrc == "mpi" ] && \rm -f *.o *.mod mpisrc="null_mpi" -windowsrc="" m="" # Serial programs From 8dabf8d26b3d19c89db51ee3a2a6f41b07c44a85 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Fri, 1 Nov 2024 12:00:49 -0400 Subject: [PATCH 08/13] added the fotran-testanything code from dennisdjensen https://github.com/dennisdjensen/fortran-testanything license included in this commit. renamed test.f08 to test.f90 because *.f90 is what we have mkmf looking for updated buildfunctions to include the fortran-testanything code for developer tests only removed the local threed_model_mod.f90 (using the template model path like other developer tests) --- build_templates/buildfunctions.sh | 4 + .../contrib/fortran-testanything/LICENSE.txt | 14 + .../contrib/fortran-testanything/is_i.inc | 24 ++ .../contrib/fortran-testanything/is_r.inc | 83 ++++ .../contrib/fortran-testanything/test.f90 | 373 ++++++++++++++++++ developer_tests/window/work/quickbuild.sh | 2 +- .../window/work/threed_model_mod.f90 | 298 -------------- 7 files changed, 499 insertions(+), 299 deletions(-) create mode 100644 developer_tests/contrib/fortran-testanything/LICENSE.txt create mode 100644 developer_tests/contrib/fortran-testanything/is_i.inc create mode 100644 developer_tests/contrib/fortran-testanything/is_r.inc create mode 100644 developer_tests/contrib/fortran-testanything/test.f90 delete mode 100644 developer_tests/window/work/threed_model_mod.f90 diff --git a/build_templates/buildfunctions.sh b/build_templates/buildfunctions.sh index c0973ace2..1440922da 100644 --- a/build_templates/buildfunctions.sh +++ b/build_templates/buildfunctions.sh @@ -222,8 +222,10 @@ done function dartbuild() { local program +local devlibs if [ $dev_test -eq 0 ]; then + devlibs="" #look in $program directory for {main}.f90 if [ $1 == "obs_diag" ]; then program=$DART/assimilation_code/programs/obs_diag/$LOCATION @@ -235,11 +237,13 @@ if [ $dev_test -eq 0 ]; then else # For developer tests {main}.f90 is in developer_tests program=$DART/developer_tests/$TEST/$1.f90 + devlibs=$DART/developer_tests/contrib/fortran-testanything fi $DART/build_templates/mkmf -x -a $DART $m -p $1 \ $dartsrc \ $EXTRA \ + $devlibs \ $program } diff --git a/developer_tests/contrib/fortran-testanything/LICENSE.txt b/developer_tests/contrib/fortran-testanything/LICENSE.txt new file mode 100644 index 000000000..aaf4092f7 --- /dev/null +++ b/developer_tests/contrib/fortran-testanything/LICENSE.txt @@ -0,0 +1,14 @@ +Copyright 2015 Dennis Decker Jensen + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + diff --git a/developer_tests/contrib/fortran-testanything/is_i.inc b/developer_tests/contrib/fortran-testanything/is_i.inc new file mode 100644 index 000000000..7f98a0908 --- /dev/null +++ b/developer_tests/contrib/fortran-testanything/is_i.inc @@ -0,0 +1,24 @@ +! Template parameter: wp (working precision) +! Template free identifiers: testline, tests +subroutine is(got, expected, msg) + integer(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,I0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,I0)') 'expected: ', expected + + good = got == expected + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end diff --git a/developer_tests/contrib/fortran-testanything/is_r.inc b/developer_tests/contrib/fortran-testanything/is_r.inc new file mode 100644 index 000000000..98599716b --- /dev/null +++ b/developer_tests/contrib/fortran-testanything/is_r.inc @@ -0,0 +1,83 @@ +! Template parameter: wp (working precision) +! Template free identifiers: testline, tests +subroutine isabs(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + real(kind=wp) tolerance + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected + + if (present(eps)) then + tolerance = eps + else + tolerance = epsilon(got) + end if + ! eps = 0.5e-10_wp + ! Absolute accuracy within the 10 least significant digits + good = abs(got - expected) < tolerance + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end + +subroutine isrel(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + real(kind=wp) tolerance + + ! eps = (abs(a) + abs(b)) * 0.5e-10_wp + ! Relative accuracy within the 10 most significant digits + tolerance = (abs(got) + abs(expected)) + if (present(eps)) then + tolerance = tolerance * eps + else + tolerance = tolerance * epsilon(got) + end if + call isabs(got, expected, tolerance, msg) +end + +subroutine isnear(got, expected, eps, msg) + real(kind=wp), intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + real(kind=wp), intent(in), optional :: eps + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + real(kind=wp) tolerance + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected + + if (present(eps)) then + tolerance = eps + else + tolerance = epsilon(got) ! minimun eps for which 1 + eps /= 1 + end if + ! Relative accuracy around 1.0_wp + ! Semantics of isnear means using <=, and not <, c.f. epsilon(got) + good = abs(got / expected - 1.0_wp) <= tolerance + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) +end + diff --git a/developer_tests/contrib/fortran-testanything/test.f90 b/developer_tests/contrib/fortran-testanything/test.f90 new file mode 100644 index 000000000..5b565779d --- /dev/null +++ b/developer_tests/contrib/fortran-testanything/test.f90 @@ -0,0 +1,373 @@ +! Copyright 2015 Dennis Decker Jensen +! See and +! Tectonics: gfortran -g -Wall -Wextra -std=f2008ts -c test.f08 + +module test_base + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit + implicit none + + ! Kept as variables instead of aliases, + ! so that test output or diagnostic output can be redirected + integer :: test_unit = output_unit, diag_unit = error_unit + + integer :: tests = 0, todos = 0 + character(len=120) :: todomsg = "" + + interface todo + module procedure todo_i, todo_s, todo_s_i, todo + end interface + +contains + + subroutine diag(msg) + character(len=*), intent(in) :: msg + write (diag_unit, '("# ",A)') trim(msg) ! only trailing spaces + end + + subroutine note(msg) + character(len=*), intent(in) :: msg + write (test_unit, '("# ",A)') trim(msg) + end + + subroutine testline(ok, msg, idmsg, gotmsg, expectedmsg) + logical, intent(in) :: ok + character(len=*), intent(in) :: msg, idmsg, gotmsg, expectedmsg + + tests = tests + 1 + if (.not. ok) call out("not ") + write (test_unit, '("ok ",I0)', advance="NO") tests + + if (msg /= "" .or. todos > 0) call out(" - ") + + if (msg /= "") call out(trim(msg)) + + if (todos > 0) then + todos = todos - 1 + if (msg /= "") call out(" ") + call out("# TODO") + if (todomsg .ne. "") then + call out(": ") + call out(trim(todomsg)) + end if + end if + if (todos == 0) todomsg = "" + + write (test_unit, *) "" + + if (.not. ok) then + ! 3 spaces prepended = 4 spaces indentation after # on diag + if (idmsg /= "") call diag(" " // idmsg) + if (gotmsg /= "") call diag(" " // gotmsg) + if (expectedmsg /= "") call diag(" " // expectedmsg) + end if + contains + subroutine out(str) + character(len=*), intent(in) :: str + write (test_unit, '(A)', advance="NO") str + end + end subroutine testline + + subroutine ok(condition, msg) + logical, intent(in) :: condition + character(len=*), intent(in), optional :: msg + if (present(msg)) then + call testline(condition, msg, "", "", "") + else + call testline(condition, "", "", "", "") + end if + end + + subroutine pass(msg) + character(len=*), intent(in), optional :: msg + call ok(.true., msg) + end + + subroutine fail(msg) + character(len=*), intent(in), optional :: msg + call ok(.false., msg) + end + + subroutine todo_s_i(msg, howmany) + character(len=*), intent(in) :: msg + integer, intent(in) :: howmany + todomsg = msg + todos = howmany + end + + subroutine todo + call todo_s_i("", 1) + end + + subroutine todo_s(msg) + character(len=*), intent(in) :: msg + call todo_s_i(msg, 1) + end + + subroutine todo_i(howmany) + integer, intent(in) :: howmany + call todo_s_i("", howmany) + end + +end module test_base + +module test_planning + use test_base, only: test_unit, tests + implicit none + + integer, private :: planned = 0 + +contains + + subroutine bail_out(msg) + character(len=*), intent(in), optional :: msg + if (present(msg)) then + write (test_unit, '("Bail out! ",A)') msg + else + write (test_unit, '("Bail out!")') + end if + stop + end + + subroutine plan(tests) + integer, intent(in) :: tests + + select case (tests) + case (:-1) + call bail_out("A plan with a negative number of tests") + case (0) + write (test_unit, '("1..0")') + stop ! The same as skip_all without a given reason + case (1:) + if (planned > 0) & + & call bail_out("More than one plan in test output") + planned = tests + write (test_unit, '("1..",I0)') planned + end select + end + + subroutine done_testing(howmany) + integer, intent(in), optional :: howmany + + ! Put plan at the end of test output + if (present(howmany)) then + call plan(howmany) + else + if (planned == 0) call plan(tests) + ! else - We already have a plan + end if + end + + subroutine skip_all(msg) + character(len=*), intent(in), optional :: msg + if (present(msg)) then + write (test_unit, '("1..0 # Skipped: ",A)') msg + else + write (test_unit, '("1..0 # Skipped all")') + end if + stop + end + +end module test_planning + +! Template instances of integer kinds for "is" + +module is_i8_mod + use, intrinsic :: iso_fortran_env, only: wp => int8 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_i.inc" +end + +module is_i16_mod + use, intrinsic :: iso_fortran_env, only: wp => int16 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_i.inc" +end + +module is_i32_mod + use, intrinsic :: iso_fortran_env, only: wp => int32 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_i.inc" +end + +module is_i64_mod + use, intrinsic :: iso_fortran_env, only: wp => int64 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_i.inc" +end + +module is_i + use is_i8_mod, only: is_i8 => is + use is_i16_mod, only: is_i16 => is + use is_i32_mod, only: is_i32 => is + use is_i64_mod, only: is_i64 => is + interface is + module procedure is_i8, is_i16, is_i32, is_i64 + end interface +end + +! Template instances of real kinds for "is" + +module is_r32_mod + use, intrinsic :: iso_fortran_env, only: wp => real32 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_r.inc" +end + +module is_r64_mod + use, intrinsic :: iso_fortran_env, only: wp => real64 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_r.inc" +end + +module is_r128_mod + use, intrinsic :: iso_fortran_env, only: wp => real128 + use, non_intrinsic :: test_base, only: testline, tests +contains + include "is_r.inc" +end + +module is_r + use is_r32_mod, only: isrel_r32 => isrel, isabs_r32 => isabs, & + & isnear_r32 => isnear + use is_r64_mod, only: isrel_r64 => isrel, isabs_r64 => isabs, & + & isnear_r64 => isnear + use is_r128_mod, only: isrel_r128 => isrel, isabs_r128 => isabs, & + & isnear_r128 => isnear + interface isrel + module procedure isrel_r32, isrel_r64, isrel_r128 + end interface + + interface isabs + module procedure isabs_r32, isabs_r64, isabs_r128 + end interface + + interface isnear + module procedure isnear_r32, isnear_r64, isnear_r128 + end interface +end + +module test_more + use test_base, only: testline, tests, test_unit + use test_planning, only: bail_out ! for negative skips + use is_i, only: is, is_i8, is_i16, is_i32, is_i64 + use is_r, only: isabs, isrel, isnear, & + & isabs_r32, isrel_r32, isnear_r32, & + & isabs_r64, isrel_r64, isnear_r64, & + & isabs_r128, isrel_r128, isnear_r128 + + ! Complex numbers cannot be compared, hence no is_c module + + implicit none + + interface skip + module procedure skip_i, skip_s, skip_s_i, skip + end interface + + interface is + module procedure is_s, is_l + end interface + +contains + + subroutine skip_s_i(msg, howmany) + character(len=*), intent(in) :: msg + integer, intent(in) :: howmany + character(len=120) skipmsg + integer i + + if (howmany <= 0) then + call bail_out("Skipped non-positive number of tests") + end if + + if (msg == "") then + skipmsg = "# SKIP" + else + skipmsg = "# SKIP: " // trim(msg) + end if + + do i = 1, howmany + tests = tests + 1 + write (test_unit, '("ok ",I0," ",A)') tests, trim(skipmsg) + end do + end + + subroutine skip + call skip_s_i("", 1) + end + + subroutine skip_s(msg) + character(len=*), intent(in) :: msg + call skip_s_i(msg, 1) + end + + subroutine skip_i(howmany) + integer, intent(in) :: howmany + call skip_s_i("", howmany) + end + + ! Duplicates of is_i routines in file is_i.inc and ditto is_r + ! They are not factored any further, because it is easier + ! to see all the output together rather than in separate routines + + subroutine is_s(got, expected, msg) + character(len=*), intent(in) :: got + character(len=*), intent(in) :: expected + character(len=*), intent(in), optional :: msg + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,A,A)') ' got: "', got, '"' + write (unit=expectedmsg, fmt='(A,A,A)') 'expected: "', expected, '"' + + good = got == expected + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) + end + + subroutine is_l(got, expected, msg) + logical, intent(in) :: got, expected + character(len=*), intent(in), optional :: msg + character(len=:), allocatable :: testmsg, idmsg + character(len=120) gotmsg, expectedmsg + logical good + + if (present(msg)) then + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' + testmsg = trim(msg) + else + allocate(character(len=30) :: testmsg, idmsg) + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 + testmsg = "" + end if + write (unit=gotmsg, fmt='(A,L1)') ' got: ', got + write (unit=expectedmsg, fmt='(A,L1)') 'expected: ', expected + + good = got .eqv. expected + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) + end + +end module test_more + +module test + use test_base, only: test_unit, diag_unit, & + & ok, diag, note, pass, fail, todo + use test_planning, only: plan, done_testing, skip_all, bail_out + use test_more, only: is, isabs, isrel, isnear, skip +end module test + diff --git a/developer_tests/window/work/quickbuild.sh b/developer_tests/window/work/quickbuild.sh index a9165534a..5482d0f19 100755 --- a/developer_tests/window/work/quickbuild.sh +++ b/developer_tests/window/work/quickbuild.sh @@ -11,7 +11,7 @@ export DART=$(git rev-parse --show-toplevel) source "$DART"/build_templates/buildfunctions.sh MODEL="none" -EXTRA=/Users/hkershaw/DART/issues/fortran-testanything +EXTRA=$DART/models/template/threed_model_mod.f90 dev_test=1 LOCATION="threed_sphere" TEST="window" diff --git a/developer_tests/window/work/threed_model_mod.f90 b/developer_tests/window/work/threed_model_mod.f90 deleted file mode 100644 index 07976db5d..000000000 --- a/developer_tests/window/work/threed_model_mod.f90 +++ /dev/null @@ -1,298 +0,0 @@ -! DART software - Copyright UCAR. This open source software is provided -! by UCAR, "as is", without charge, subject to all terms of use at -! http://www.image.ucar.edu/DAReS/DART/DART_download -! - -module model_mod - -! This is a template showing the interfaces required for a model to be compliant -! with the DART data assimilation infrastructure. Do not change the arguments -! for the public routines. - -use types_mod, only : r8, i8, MISSING_R8 - -use time_manager_mod, only : time_type, set_time - -use location_mod, only : location_type, get_close_type, & - loc_get_close_obs => get_close_obs, & - loc_get_close_state => get_close_state, & - set_location, set_location_missing - -use utilities_mod, only : error_handler, & - E_ERR, E_MSG, & - nmlfileunit, do_output, do_nml_file, do_nml_term, & - find_namelist_in_file, check_namelist_read - -use netcdf_utilities_mod, only : nc_add_global_attribute, nc_synchronize_file, & - nc_add_global_creation_time, & - nc_begin_define_mode, nc_end_define_mode - -use state_structure_mod, only : add_domain, get_domain_size - -use ensemble_manager_mod, only : ensemble_type - -! These routines are passed through from default_model_mod. -! To write model specific versions of these routines -! remove the routine from this use statement and add your code to -! this the file. -use default_model_mod, only : pert_model_copies, read_model_time, write_model_time, & - init_time => fail_init_time, & - init_conditions => fail_init_conditions, & - convert_vertical_obs, convert_vertical_state, adv_1step - -implicit none -private - -! routines required by DART code - will be called from filter and other -! DART executables. -public :: get_model_size, & - get_state_meta_data, & - model_interpolate, & - end_model, & - static_init_model, & - nc_write_model_atts, & - get_close_obs, & - get_close_state, & - pert_model_copies, & - convert_vertical_obs, & - convert_vertical_state, & - read_model_time, & - adv_1step, & - init_time, & - init_conditions, & - shortest_time_between_assimilations, & - write_model_time - - -character(len=256), parameter :: source = "model_mod.f90" -logical :: module_initialized = .false. -integer :: dom_id ! used to access the state structure -type(time_type) :: assimilation_time_step - -! Example Namelist -! Use the namelist for options to be set at runtime. -character(len=256) :: template_file = 'model_restart.nc' -integer :: time_step_days = 0 -integer :: time_step_seconds = 3600 - -namelist /model_nml/ template_file, time_step_days, time_step_seconds - -contains - -!------------------------------------------------------------------ -! -! Called to do one time initialization of the model. As examples, -! might define information about the model size or model timestep. -! In models that require pre-computed static data, for instance -! spherical harmonic weights, these would also be computed here. - -subroutine static_init_model() - -integer :: iunit, io - -module_initialized = .true. - -call find_namelist_in_file("input.nml", "model_nml", iunit) -read(iunit, nml = model_nml, iostat = io) -call check_namelist_read(iunit, io, "model_nml") - -! Record the namelist values used for the run -if (do_nml_file()) write(nmlfileunit, nml=model_nml) -if (do_nml_term()) write( * , nml=model_nml) - -! This time is both the minimum time you can ask the model to advance -! (for models that can be advanced by filter) and it sets the assimilation -! window. All observations within +/- 1/2 this interval from the current -! model time will be assimilated. If this is not settable at runtime -! feel free to hardcode it and remove from the namelist. -assimilation_time_step = set_time(time_step_seconds, & - time_step_days) - - -! Define which variables are in the model state -dom_id = add_domain(template_file, num_vars=2, var_names=(/'Temp', 'Wind'/)) - -end subroutine static_init_model - -!------------------------------------------------------------------ -! Returns the number of items in the state vector as an integer. - -function get_model_size() - -integer(i8) :: get_model_size - -if ( .not. module_initialized ) call static_init_model - -get_model_size = get_domain_size(dom_id) - -end function get_model_size - - -!------------------------------------------------------------------ -! Given a state handle, a location, and a state quantity, -! interpolates the state variable fields to that location and returns -! the values in expected_obs. The istatus variables should be returned as -! 0 unless there is some problem in computing the interpolation in -! which case a positive istatus should be returned. -! -! For applications in which only perfect model experiments -! with identity observations (i.e. only the value of a particular -! state variable is observed), this can be a NULL INTERFACE. - -subroutine model_interpolate(state_handle, ens_size, location, qty, expected_obs, istatus) - - -type(ensemble_type), intent(in) :: state_handle -integer, intent(in) :: ens_size -type(location_type), intent(in) :: location -integer, intent(in) :: qty -real(r8), intent(out) :: expected_obs(ens_size) !< array of interpolated values -integer, intent(out) :: istatus(ens_size) - -if ( .not. module_initialized ) call static_init_model - -! This should be the result of the interpolation of a -! given kind (itype) of variable at the given location. -expected_obs(:) = MISSING_R8 - -! istatus for successful return should be 0. -! Any positive number is an error. -! Negative values are reserved for use by the DART framework. -! Using distinct positive values for different types of errors can be -! useful in diagnosing problems. -istatus(:) = 1 - -end subroutine model_interpolate - - - -!------------------------------------------------------------------ -! Returns the smallest increment in time that the model is capable -! of advancing the state in a given implementation, or the shortest -! time you want the model to advance between assimilations. - -function shortest_time_between_assimilations() - -type(time_type) :: shortest_time_between_assimilations - -if ( .not. module_initialized ) call static_init_model - -shortest_time_between_assimilations = assimilation_time_step - -end function shortest_time_between_assimilations - - - -!------------------------------------------------------------------ -! Given an integer index into the state vector, returns the -! associated location and optionally the physical quantity. - -subroutine get_state_meta_data(index_in, location, qty) - -integer(i8), intent(in) :: index_in -type(location_type), intent(out) :: location -integer, intent(out), optional :: qty - - -if ( .not. module_initialized ) call static_init_model - -! should be set to the actual location using set_location() -location = set_location_missing() - -! should be set to the physical quantity, e.g. QTY_TEMPERATURE -if (present(qty)) qty = 0 - -end subroutine get_state_meta_data - - -!------------------------------------------------------------------ -! Any model specific distance calcualtion can be done here -subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & - num_close, close_ind, dist, ens_handle) - -type(get_close_type), intent(in) :: gc ! handle to a get_close structure -integer, intent(in) :: base_type ! observation TYPE -type(location_type), intent(inout) :: base_loc ! location of interest -type(location_type), intent(inout) :: locs(:) ! obs locations -integer, intent(in) :: loc_qtys(:) ! QTYS for obs -integer, intent(in) :: loc_types(:) ! TYPES for obs -integer, intent(out) :: num_close ! how many are close -integer, intent(out) :: close_ind(:) ! incidies into the locs array -real(r8), optional, intent(out) :: dist(:) ! distances in radians -type(ensemble_type), optional, intent(in) :: ens_handle - -character(len=*), parameter :: routine = 'get_close_obs' - -call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & - num_close, close_ind, dist, ens_handle) - -end subroutine get_close_obs - - -!------------------------------------------------------------------ -! Any model specific distance calcualtion can be done here -subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & - num_close, close_ind, dist, ens_handle) - -type(get_close_type), intent(in) :: gc ! handle to a get_close structure -type(location_type), intent(inout) :: base_loc ! location of interest -integer, intent(in) :: base_type ! observation TYPE -type(location_type), intent(inout) :: locs(:) ! state locations -integer, intent(in) :: loc_qtys(:) ! QTYs for state -integer(i8), intent(in) :: loc_indx(:) ! indices into DART state vector -integer, intent(out) :: num_close ! how many are close -integer, intent(out) :: close_ind(:) ! indices into the locs array -real(r8), optional, intent(out) :: dist(:) ! distances in radians -type(ensemble_type), optional, intent(in) :: ens_handle - -character(len=*), parameter :: routine = 'get_close_state' - - -call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & - num_close, close_ind, dist, ens_handle) - - -end subroutine get_close_state - - -!------------------------------------------------------------------ -! Does any shutdown and clean-up needed for model. Can be a NULL -! INTERFACE if the model has no need to clean up storage, etc. - -subroutine end_model() - - -end subroutine end_model - - -!------------------------------------------------------------------ -! write any additional attributes to the output and diagnostic files - -subroutine nc_write_model_atts(ncid, domain_id) - -integer, intent(in) :: ncid ! netCDF file identifier -integer, intent(in) :: domain_id - -if ( .not. module_initialized ) call static_init_model - -! put file into define mode. - -call nc_begin_define_mode(ncid) - -call nc_add_global_creation_time(ncid) - -call nc_add_global_attribute(ncid, "model_source", source ) -call nc_add_global_attribute(ncid, "model", "template") - -call nc_end_define_mode(ncid) - -! Flush the buffer and leave netCDF file open -call nc_synchronize_file(ncid) - -end subroutine nc_write_model_atts - -!=================================================================== -! End of model_mod -!=================================================================== -end module model_mod - From 4ee33d4a7e9f800f1152ef151884d893f22233e9 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Fri, 1 Nov 2024 12:19:40 -0400 Subject: [PATCH 09/13] remove old comments re https://github.com/NCAR/DART/pull/735#pullrequestreview-2406069283 --- assimilation_code/modules/utilities/win_mod.f90 | 2 -- assimilation_code/modules/utilities/winf08_mod.f90 | 2 -- 2 files changed, 4 deletions(-) diff --git a/assimilation_code/modules/utilities/win_mod.f90 b/assimilation_code/modules/utilities/win_mod.f90 index a81a41114..d73e17286 100644 --- a/assimilation_code/modules/utilities/win_mod.f90 +++ b/assimilation_code/modules/utilities/win_mod.f90 @@ -29,8 +29,6 @@ module window_mod integer :: current_win !< keep track of current window, start out assuming an invalid window ! parameters for keeping track of which window is open -!>@todo should this be in the window_mod? you will have to change in both cray -!> and non cray versions integer, parameter :: NO_WINDOW = -1 integer, parameter :: MEAN_WINDOW = 0 integer, parameter :: STATE_WINDOW = 2 diff --git a/assimilation_code/modules/utilities/winf08_mod.f90 b/assimilation_code/modules/utilities/winf08_mod.f90 index 755e8c90b..8e0939c3d 100644 --- a/assimilation_code/modules/utilities/winf08_mod.f90 +++ b/assimilation_code/modules/utilities/winf08_mod.f90 @@ -29,8 +29,6 @@ module window_mod integer :: current_win !< keep track of current window, start out assuming an invalid window ! parameters for keeping track of which window is open -!>@todo should this be in the window_mod? you will have to change in both cray -!> and non cray versions integer, parameter :: NO_WINDOW = -1 integer, parameter :: MEAN_WINDOW = 0 integer, parameter :: STATE_WINDOW = 2 From fcfd7210c3f70980737b16e59ab17622c3a26012 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Fri, 1 Nov 2024 12:24:38 -0400 Subject: [PATCH 10/13] comment fix to be specific about which ensemble_handle re https://github.com/NCAR/DART/pull/735#discussion_r1823261390 --- assimilation_code/modules/utilities/win_mod.f90 | 2 +- assimilation_code/modules/utilities/winf08_mod.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/assimilation_code/modules/utilities/win_mod.f90 b/assimilation_code/modules/utilities/win_mod.f90 index d73e17286..e96526100 100644 --- a/assimilation_code/modules/utilities/win_mod.f90 +++ b/assimilation_code/modules/utilities/win_mod.f90 @@ -59,7 +59,7 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl integer :: bytesize !< size in bytes of each element in the window integer :: my_num_vars !< my number of vars -! Find out how many copies to get, maybe different to %num_copies +! Find out how many copies to get, maybe different to state_ens_handle%num_copies data_count = copies_in_window(state_ens_handle) if (get_allow_transpose(state_ens_handle)) then diff --git a/assimilation_code/modules/utilities/winf08_mod.f90 b/assimilation_code/modules/utilities/winf08_mod.f90 index 8e0939c3d..54f14de3d 100644 --- a/assimilation_code/modules/utilities/winf08_mod.f90 +++ b/assimilation_code/modules/utilities/winf08_mod.f90 @@ -59,7 +59,7 @@ subroutine create_state_window(state_ens_handle, fwd_op_ens_handle, qc_ens_handl integer :: bytesize !< size in bytes of each element in the window integer :: my_num_vars !< my number of vars -! Find out how many copies to get, maybe different to %num_copies +! Find out how many copies to get, maybe different to state_ens_handle%num_copies data_count = copies_in_window(state_ens_handle) if (get_allow_transpose(state_ens_handle)) then From 55eaccd61fca194464f196c629465b71433bfd59 Mon Sep 17 00:00:00 2001 From: Marlee Smith Date: Tue, 5 Nov 2024 16:16:28 -0700 Subject: [PATCH 11/13] Removing loops in time_manager_mod that are not needed --- .../modules/utilities/time_manager_mod.f90 | 92 ++++++++----------- 1 file changed, 37 insertions(+), 55 deletions(-) diff --git a/assimilation_code/modules/utilities/time_manager_mod.f90 b/assimilation_code/modules/utilities/time_manager_mod.f90 index db35f4fd3..c74230dff 100644 --- a/assimilation_code/modules/utilities/time_manager_mod.f90 +++ b/assimilation_code/modules/utilities/time_manager_mod.f90 @@ -694,7 +694,6 @@ subroutine set_calendar_type_string(calstring) character(len=len(calstring)) :: str1 character(len=max_calendar_string_length) :: cstring logical :: found_calendar = .false. -integer :: i if ( .not. module_initialized ) call time_manager_init @@ -714,47 +713,34 @@ subroutine set_calendar_type_string(calstring) ! We must check for the gregorian_mars calendar before ! the gregorian calendar for similar reasons. -WhichCalendar : do i = 0, max_type - - if ( cstring == 'NO_CALENDAR' ) then - calendar_type = NO_CALENDAR - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'NO CALENDAR' ) then ! allow this as a synonym - calendar_type = NO_CALENDAR - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'NONE' ) then ! also allow this - calendar_type = NO_CALENDAR - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'THIRTY_DAY_MONTHS' ) then - calendar_type = THIRTY_DAY_MONTHS - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'JULIAN' ) then - calendar_type = JULIAN - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'NOLEAP' ) then - calendar_type = NOLEAP - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'GREGORIAN_MARS' ) then - calendar_type = GREGORIAN_MARS - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'SOLAR_MARS' ) then - calendar_type = SOLAR_MARS - found_calendar = .true. - exit WhichCalendar - elseif ( cstring == 'GREGORIAN' ) then - calendar_type = GREGORIAN - found_calendar = .true. - exit WhichCalendar - endif - -enddo WhichCalendar +if ( cstring == 'NO_CALENDAR' ) then + calendar_type = NO_CALENDAR + found_calendar = .true. +elseif ( cstring == 'NO CALENDAR' ) then ! allow this as a synonym + calendar_type = NO_CALENDAR + found_calendar = .true. +elseif ( cstring == 'NONE' ) then ! also allow this + calendar_type = NO_CALENDAR + found_calendar = .true. +elseif ( cstring == 'THIRTY_DAY_MONTHS' ) then + calendar_type = THIRTY_DAY_MONTHS + found_calendar = .true. +elseif ( cstring == 'JULIAN' ) then + calendar_type = JULIAN + found_calendar = .true. +elseif ( cstring == 'NOLEAP' ) then + calendar_type = NOLEAP + found_calendar = .true. +elseif ( cstring == 'GREGORIAN_MARS' ) then + calendar_type = GREGORIAN_MARS + found_calendar = .true. +elseif ( cstring == 'SOLAR_MARS' ) then + calendar_type = SOLAR_MARS + found_calendar = .true. +elseif ( cstring == 'GREGORIAN' ) then + calendar_type = GREGORIAN + found_calendar = .true. +endif if( .not. found_calendar ) then write(errstring,*)'Unknown calendar ',calstring @@ -785,23 +771,19 @@ subroutine get_calendar_string(mystring) ! ! Returns default calendar type for mapping from time to date. -character(len=*), intent(OUT) :: mystring - -integer :: i +character(len=*), intent(out) :: mystring if ( .not. module_initialized ) call time_manager_init -mystring = ' ' +mystring = '' -do i = 0,max_type - if (calendar_type == JULIAN) mystring = 'JULIAN' - if (calendar_type == NOLEAP) mystring = 'NOLEAP' - if (calendar_type == GREGORIAN) mystring = 'GREGORIAN' - if (calendar_type == NO_CALENDAR) mystring = 'NO_CALENDAR' - if (calendar_type == GREGORIAN_MARS) mystring = 'GREGORIAN_MARS' - if (calendar_type == SOLAR_MARS) mystring = 'SOLAR_MARS' - if (calendar_type == THIRTY_DAY_MONTHS) mystring = 'THIRTY_DAY_MONTHS' -enddo +if (calendar_type == JULIAN) mystring = 'JULIAN' +if (calendar_type == NOLEAP) mystring = 'NOLEAP' +if (calendar_type == GREGORIAN) mystring = 'GREGORIAN' +if (calendar_type == NO_CALENDAR) mystring = 'NO_CALENDAR' +if (calendar_type == GREGORIAN_MARS) mystring = 'GREGORIAN_MARS' +if (calendar_type == SOLAR_MARS) mystring = 'SOLAR_MARS' +if (calendar_type == THIRTY_DAY_MONTHS) mystring = 'THIRTY_DAY_MONTHS' if (len_trim(mystring) < 3) then write(errstring,*)'unknown calendar type ', calendar_type From 697792bb3485abb398f6c8ed16125eaf9f1d78e8 Mon Sep 17 00:00:00 2001 From: Marlee Smith Date: Wed, 6 Nov 2024 15:01:12 -0700 Subject: [PATCH 12/13] Removing found_calendar var and corresponding check --- .../modules/utilities/time_manager_mod.f90 | 20 +++++-------------- 1 file changed, 5 insertions(+), 15 deletions(-) diff --git a/assimilation_code/modules/utilities/time_manager_mod.f90 b/assimilation_code/modules/utilities/time_manager_mod.f90 index c74230dff..cdc88517a 100644 --- a/assimilation_code/modules/utilities/time_manager_mod.f90 +++ b/assimilation_code/modules/utilities/time_manager_mod.f90 @@ -665,7 +665,8 @@ end function repeat_alarm !========================================================================= subroutine set_calendar_type_integer(mytype) - +!------------------------------------------------------------------------ +! ! Selects calendar for default mapping from time to date - if you know ! the magic integer for the calendar of interest. @@ -684,7 +685,8 @@ end subroutine set_calendar_type_integer subroutine set_calendar_type_string(calstring) - +!------------------------------------------------------------------------ +! ! Selects calendar for default mapping from time to date - given a string. character(len=*), intent(in) :: calstring @@ -693,7 +695,6 @@ subroutine set_calendar_type_string(calstring) character(len=len(calstring)) :: str1 character(len=max_calendar_string_length) :: cstring -logical :: found_calendar = .false. if ( .not. module_initialized ) call time_manager_init @@ -715,34 +716,23 @@ subroutine set_calendar_type_string(calstring) if ( cstring == 'NO_CALENDAR' ) then calendar_type = NO_CALENDAR - found_calendar = .true. elseif ( cstring == 'NO CALENDAR' ) then ! allow this as a synonym calendar_type = NO_CALENDAR - found_calendar = .true. elseif ( cstring == 'NONE' ) then ! also allow this calendar_type = NO_CALENDAR - found_calendar = .true. elseif ( cstring == 'THIRTY_DAY_MONTHS' ) then calendar_type = THIRTY_DAY_MONTHS - found_calendar = .true. elseif ( cstring == 'JULIAN' ) then calendar_type = JULIAN - found_calendar = .true. elseif ( cstring == 'NOLEAP' ) then calendar_type = NOLEAP - found_calendar = .true. elseif ( cstring == 'GREGORIAN_MARS' ) then calendar_type = GREGORIAN_MARS - found_calendar = .true. elseif ( cstring == 'SOLAR_MARS' ) then calendar_type = SOLAR_MARS - found_calendar = .true. elseif ( cstring == 'GREGORIAN' ) then calendar_type = GREGORIAN - found_calendar = .true. -endif - -if( .not. found_calendar ) then +else write(errstring,*)'Unknown calendar ',calstring call error_handler(E_ERR,'set_calendar_type_string',errstring,source) endif From d56aa4a0d7f3d84c3f674547954012b2d2cc94d5 Mon Sep 17 00:00:00 2001 From: Helen Kershaw Date: Thu, 7 Nov 2024 15:16:03 -0500 Subject: [PATCH 13/13] bump conf.py and changelog for release adding missing v to tags in changelog attribution to dennisdjensen for fortran-testanything --- CHANGELOG.rst | 17 ++++++++++++----- conf.py | 2 +- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.rst b/CHANGELOG.rst index b46654545..b15c62115 100644 --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -22,17 +22,24 @@ individual files. The changes are now listed with the most recent at the top. -**October 22 2024 :: Bug-fixes: WRF and GOES. Tag 11.8.2** +**November 7 2024 :: MPI window memory reduction. Tag v11.8.3** + +- Removes unnecessary copy of state into mpi window. +- Removes cray pointer version of the mpi window. +- | Fortran-testanything included in developer tests. + | *From dennisdjensen: see developer_tests/contrib/fortran-testanything/LICENSE.txt* + +**October 22 2024 :: Bug-fixes: WRF and GOES. Tag v11.8.2** - Force THM to be the WRF-DART temperature variable - Remove offset on GOES observation converter -**September 27 2024 :: MOM6 mask bug-fix. Tag 11.8.1** +**September 27 2024 :: MOM6 mask bug-fix. Tag v11.8.1** - Fix for MOM6 CESM3 workhorse 2/3 degree grid TL319_t232 to mask missing geolon|lat|u|v|t values -**September 10 2024 :: MARBL_column. Tag 11.8.0** +**September 10 2024 :: MARBL_column. Tag v11.8.0** - Interface for MARBL_column for DART: @@ -48,7 +55,7 @@ Bugfix: - fix for IO for NetCDF files when only some variables have the unlimited dimension -**August 29 2024 :: Bug fixes for shortest_time_between_assimilations and get_close_init. Tag 11.7.1** +**August 29 2024 :: Bug fixes for shortest_time_between_assimilations and get_close_init. Tag v11.7.1** Bug fixes: @@ -64,7 +71,7 @@ Doc fixes: - GitHub template for reporting documentation issues -**August 26 2024 :: KQCEF. Tag 11.7.0** +**August 26 2024 :: KQCEF. Tag v11.7.0** - Adds a Quantile-Conserving Ensemble Filter Based on Kernel-Density Estimation to DART. - New distribution module kde_distribution_mod. diff --git a/conf.py b/conf.py index 902f7875d..23c29119d 100644 --- a/conf.py +++ b/conf.py @@ -21,7 +21,7 @@ author = 'Data Assimilation Research Section' # The full version, including alpha/beta/rc tags -release = '11.8.2' +release = '11.8.3' root_doc = 'index' # -- General configuration ---------------------------------------------------