From 488dfa195f0f9abb2fb4c9e74d63f14b00b92be0 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Thu, 2 Feb 2023 14:40:14 -0500 Subject: [PATCH] Fix race conditions + add send_data tests --- diag_manager/diag_manager.F90 | 5 +- test_fms/diag_manager/test_diag_manager2.sh | 10 ++ test_fms/diag_manager/test_modern_diag.F90 | 137 +++++++++++++++++--- 3 files changed, 131 insertions(+), 21 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index a83abc2a25..2960de0f58 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1616,7 +1616,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CHARACTER(len=128) :: error_string, error_string1 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - class(*), pointer, dimension(:,:,:,:) :: field_modern => null() !< i8 4d remapped pointer + class(*), pointer, dimension(:,:,:,:) :: field_modern !< i8 4d remapped pointer ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN send_data_3d = .FALSE. @@ -1647,6 +1647,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN END IF if (use_modern_diag) then !> Set up array lengths for remapping + field_modern => null() ie = SIZE(field,1) je = SIZE(field,2) ke = SIZE(field,3) @@ -1666,7 +1667,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & modern_if: iF (use_modern_diag) then send_data_3d = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) - deallocate (field_modern) + nullify (field_modern) elSE ! modern_if ! oor_mask is only used for checking out of range values. ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 2cee1c65bd..a76e80e0b3 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -652,6 +652,16 @@ title: test_diag_manager base_date: 2 1 1 0 0 0 diag_files: +- file_name: static_file + freq: -1 + freq_units: hours + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var7 + reduction: none + kind: r4 - file_name: file1 freq: 6 freq_units: hours diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90 index f557470dc1..8d9e6d20e9 100644 --- a/test_fms/diag_manager/test_modern_diag.F90 +++ b/test_fms/diag_manager/test_modern_diag.F90 @@ -26,14 +26,25 @@ program test_modern_diag mpp_get_UG_compute_domain use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, & diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, & - diag_manager_set_time_end + diag_manager_set_time_end, send_data, register_static_field +use platform_mod, only: r8_kind, r4_kind use fms_mod, only: fms_init, fms_end -use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast +use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time use fms_diag_object_mod,only: dump_diag_obj implicit none +!> @brief Type to hold all the dummy data variables +type data_type + real(kind=r8_kind), allocatable :: var1(:,:) !< Dummy data for var1 + real(kind=r8_kind), allocatable :: var2(:,:) !< Dummy data for var2 + real(kind=r8_kind), allocatable :: var3(:,:) !< Dummy data for var3 + real(kind=r8_kind), allocatable :: var4(:,:,:) !< Dummy data for var4 + real(kind=r8_kind), allocatable :: var5(:) !< Dummy data for var5 + real(kind=r8_kind), allocatable :: var6(:) !< Dummy data for var6 +end type data_type + type(time_type) :: Time !< Time of the simulation integer, dimension(2) :: layout !< Layout to use when setting up the domain integer, dimension(2) :: io_layout !< io layout to use when setting up the io domain @@ -55,18 +66,30 @@ program test_modern_diag integer :: id_y3 !< axis id for the y dimension in the cube sphere domain integer :: id_UG !< axis id for the unstructured dimension integer :: id_z !< axis id for the z dimention +integer :: id_z2 !< axis id for the z dimention integer :: id_var1 !< diag_field id for var in lon/lat grid integer :: id_var2 !< diag_field id for var in lat/lon grid integer :: id_var3 !< diag_field id for var in cube sphere grid integer :: id_var4 !< diag_field id for 3d var in cube sphere grid integer :: id_var5 !< diag_field id for var in UG grid integer :: id_var6 !< diag_field id for var that is not domain decomposed -integer :: id_var7 !< Scalar var +integer :: id_var7 !< 1D var +integer :: id_var8 !< Scalar var +type(data_type) :: var_data !< Dummy variable data to send to diag_manager +logical :: used !< Used for send_data call +integer :: io_status !< Status after reading the namelist +logical :: debug = .false. !< Flag used to ignore the axis/field_ids checks in the test. + !! Useful when using a portion or a different diag_table.yaml + +namelist / test_modern_diag_nml / debug call fms_init call set_calendar_type(JULIAN) call diag_manager_init +read (input_nml_file, test_modern_diag_nml, iostat=io_status) +if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml') + nx = 96 ny = 96 nz = 5 @@ -108,7 +131,9 @@ program test_modern_diag id_ug = diag_axis_init("grid_index", real(ug_dim_data), "none", "U", long_name="grid indices", & set_name="land", DomainU=land_domain, aux="geolon_t geolat_t") -id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z') +id_z2 = diag_axis_init('z_edge', z, 'point_Z', 'z', long_name='point_Z') +id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z', edges = id_z2) + call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)') call diag_axis_add_attribute (id_z, 'integer', 10) call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/)) @@ -116,12 +141,15 @@ program test_modern_diag call diag_axis_add_attribute (id_x, '1d real', (/10./)) call diag_axis_add_attribute (id_ug, 'compress', 'x y') -if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id") -if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id") -if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id") -if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id") -if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id") -if (id_z .ne. 6) call mpp_error(FATAL, "The z axis does not have the expected id") +if (.not. debug) then + if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id") + if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id") + if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id") + if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id") + if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id") + if (id_z2 .ne. 6) call mpp_error(FATAL, "The z2 axis does not have the expected id") + if (id_z .ne. 7) call mpp_error(FATAL, "The z axis does not have the expected id") +endif ! Register the variables id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions') @@ -136,14 +164,18 @@ program test_modern_diag !< This has the same name as var1, but it should have a different id because the module is different !! so it should have its own diag_obj id_var7 = register_diag_field ('lnd_mod', 'var1', Time, 'Some scalar var', 'mullions') - -if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id") -if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id") -if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id") -if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id") -if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id") -if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id") -if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id") +id_var8 = register_static_field ('atm_mod', 'var7', (/id_z/), "Be static!", "none") + +if (.not. debug) then + if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id") + if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id") + if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id") + if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id") + if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id") + if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id") + if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id") + if (id_var8 .ne. 8) call mpp_error(FATAL, "var8 does not have the expected id") +endif call diag_field_add_attribute (id_var1, "some string", "this is a string") call diag_field_add_attribute (id_var1, "integer", 10) @@ -160,9 +192,24 @@ program test_modern_diag call diag_manager_set_time_end(Time) call diag_manager_set_time_end(set_date(2,1,2,0,0,0)) +call allocate_dummy_data(var_data, domain, Domain_cube_sph, land_domain, nz) do i=1,23 - call diag_send_complete(set_date(2,1,1,i,0,0)) + Time = set_date(2,1,1,i,0,0) + call set_dummy_data(var_data, i) + used = send_data(id_var1, var_data%var1, Time) + used = send_data(id_var2, var_data%var2, Time) + used = send_data(id_var3, var_data%var3, Time) + used = send_data(id_var4, var_data%var4, Time) + used = send_data(id_var5, var_data%var5, Time) + used = send_data(id_var6, var_data%var6, Time) + used = send_data(id_var7, var_data%var6, Time) + + !TODO I don't know about this (scalar field) or how this is suppose to work #WUT + used = send_data(id_var8, var_data%var6, Time) + + call diag_send_complete(Time) enddo +call deallocate_dummy_data(var_data) call diag_manager_end(Time) call fms_end @@ -172,6 +219,57 @@ program test_modern_diag include "../fms2_io/create_atmosphere_domain.inc" include "../fms2_io/create_land_domain.inc" +!> @brief Allocates the dummy data to send to send_data +subroutine allocate_dummy_data(var, lat_lon_domain, cube_sphere, lnd_domain, nz) + type(data_type), intent(inout) :: var !< Data var to allocate + type(domain2d), intent(in) :: lat_lon_domain !< Lat/Lon domain + type(domain2d), intent(in) :: cube_sphere !< Cube sphere domain + type(domainug), intent(in) :: lnd_domain !< Land domain + integer, intent(in) :: nz !< Number of Z points + + integer :: nland !< Size of the unstructured grid per PE + integer :: is !< Starting x compute index + integer :: ie !< Ending x compute index + integer :: js !< Starting y compute index + integer :: je !< Ending y compute index + + call mpp_get_compute_domain(lat_lon_domain, is, ie, js, je) + allocate(var%var1(is:ie, js:je)) !< Variable in a lat/lon domain + allocate(var%var2(js:je, is:ie)) !< Variable in a lat/lon domain with flipped dimensions + + call mpp_get_compute_domain(cube_sphere, is, ie, js, je) + allocate(var%var3(is:ie, js:je)) !< Variable in a cube sphere domain + allocate(var%var4(is:ie, js:je, nz)) !< Variable in a 3D cube sphere domain + + call mpp_get_UG_compute_domain(lnd_domain, size=nland) + allocate(var%var5(nz)) !< Variable in the land unstructured domain + + allocate(var%var6(nz)) !< 1D variable not domain decomposed + +end subroutine allocate_dummy_data + +!> @brief Allocates the dummy data to send to send_data +subroutine deallocate_dummy_data(var) + type(data_type), intent(inout) :: var !< Data var to deallocate + + deallocate(var%var1, var%var2, var%var3, var%var4, var%var5, var%var6) +end subroutine deallocate_dummy_data + +!> @brief Sets the dummy_data to use in send_data +subroutine set_dummy_data(var, data_value) + type(data_type), intent(inout) :: var !< Data type to set + integer, intent(in) :: data_value !< Value to send the data as + + var%var1 = real(data_value, kind=r8_kind) + var%var2 = real(data_value + 1, kind=r8_kind) + var%var3 = real(data_value + 2, kind=r8_kind) + var%var4 = real(data_value + 3, kind=r8_kind) + var%var5 = real(data_value + 4, kind=r8_kind) + var%var6 = real(data_value + 5, kind=r8_kind) + +end subroutine set_dummy_data + +!> @brief Sets up a lat/lon domain subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout) type(domain2d), intent(out) :: Domain !< 2D domain integer, intent(in) :: layout(:) !< Layout to use when setting up the domain @@ -184,6 +282,7 @@ subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout) call mpp_define_io_domain(Domain, io_layout) end subroutine set_up_2D_domain +!> @brief Sets up a cube sphere domain subroutine set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout) type(domain2d), intent(out) :: Domain_cube_sph !< 2D domain integer, intent(in) :: nx !< Number of x points