From 90c98fa4e7ca173617c06d22837129cc8ee1c91e Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Mon, 6 Nov 2023 13:38:37 -0500 Subject: [PATCH] fix: replacing cray pointers with fortran pointers in mpp_scatter and gather (#1403) --- fms2_io/include/compressed_write.inc | 24 ++++++++++++------------ mpp/include/mpp_gather.fh | 29 ++++++++++++++++------------- mpp/include/mpp_scatter.fh | 19 +++++++++++-------- test_fms/fms2_io/test_bc_restart.sh | 2 +- test_fms/fms2_io/test_compressed_writes.F90 | 8 ++++---- test_fms/fms2_io/test_domain_io.F90 | 14 +++++++------- 6 files changed, 51 insertions(+), 45 deletions(-) diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc index cd2919c1..e284a089 100644 --- a/fms2_io/include/compressed_write.inc +++ b/fms2_io/include/compressed_write.inc @@ -144,22 +144,22 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & type is (integer(kind=i4_kind)) call mpp_gather(cdata, size(cdata), buf_i4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(cdata, size(cdata), buf_i8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(cdata, size(cdata), buf_r4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(cdata, size(cdata), buf_r8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) @@ -266,19 +266,19 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & select type(cdata) type is (integer(kind=i4_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) @@ -391,22 +391,22 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & type is (integer(kind=i4_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) diff --git a/mpp/include/mpp_gather.fh b/mpp/include/mpp_gather.fh index 17b09c03..8ead643f 100644 --- a/mpp/include/mpp_gather.fh +++ b/mpp/include/mpp_gather.fh @@ -111,19 +111,22 @@ end subroutine MPP_GATHER_1DV_ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) - integer, intent(in) :: is, ie, js, je - integer, dimension(:), intent(in) :: pelist - MPP_TYPE_, dimension(is:ie,js:je), intent(in) :: array_seg - MPP_TYPE_, dimension(:,:), intent(inout) :: data - logical, intent(in) :: is_root_pe - integer, optional, intent(in) :: ishift, jshift - - MPP_TYPE_ :: arr3D(size(array_seg,1),size(array_seg,2),1) - MPP_TYPE_ :: data3D(size( data,1),size( data,2),1) - pointer( aptr, arr3D ) - pointer( dptr, data3D ) - aptr = LOC(array_seg) - dptr = LOC( data) + integer, intent(in) :: is, ie, js, je + integer, dimension(:), intent(in) :: pelist + MPP_TYPE_, dimension(is:ie,js:je), target, intent(in) :: array_seg + MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: data + logical, intent(in) :: is_root_pe + integer, optional, intent(in) :: ishift, jshift + + MPP_TYPE_, pointer :: arr3D(:,:,:) + MPP_TYPE_, pointer :: data3D(:,:,:) + + arr3D(1:size(array_seg,1),1:size(array_seg,2),1:1) => array_seg + if (is_root_pe) then + data3D(1:size(data,1),1:size(data,2),1:1) => data + else + data3D => null() + endif call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) diff --git a/mpp/include/mpp_scatter.fh b/mpp/include/mpp_scatter.fh index 4223f79c..fce54f5a 100644 --- a/mpp/include/mpp_scatter.fh +++ b/mpp/include/mpp_scatter.fh @@ -29,17 +29,20 @@ subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_ro integer, intent(in) :: is, ie, js, je !< indices of segment array integer, dimension(:), intent(in) :: pelist ! array_seg + if (is_root_pe) then + data3D(1:size(data,1),1:size(data,2),1:1) => data + else + data3D => null() + endif call mpp_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) diff --git a/test_fms/fms2_io/test_bc_restart.sh b/test_fms/fms2_io/test_bc_restart.sh index 07b0081c..faac53e0 100755 --- a/test_fms/fms2_io/test_bc_restart.sh +++ b/test_fms/fms2_io/test_bc_restart.sh @@ -43,7 +43,7 @@ test_expect_failure "bad checksum" ' ' # run test 3 - test for ignoring a bad checksum -printf "&test_bc_restart_nml\n bad_checksum=.true.\n ignore_checksum=.true./" | cat > input.nml +printf "&test_bc_restart_nml\n bad_checksum=.true.\n ignore_checksum=.true.\n /" | cat > input.nml test_expect_success "ignore bad checksum" ' mpirun -n 16 ../test_bc_restart ' diff --git a/test_fms/fms2_io/test_compressed_writes.F90 b/test_fms/fms2_io/test_compressed_writes.F90 index b905be70..38d44f63 100644 --- a/test_fms/fms2_io/test_compressed_writes.F90 +++ b/test_fms/fms2_io/test_compressed_writes.F90 @@ -112,10 +112,10 @@ program test_compressed_writes character(len=*), intent(in) :: dimension_names(:) !< dimension names integer, intent(in) :: ndim !< Number of dimension - call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i8", "int64", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i4", "int", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r8", "double", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int64", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int", dimension_names(1:ndim)) end subroutine register_field_wrapper !> @brief Allocates the variable to be the size of data compute domain for x and y diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 index 07a3e284..5b00d8c9 100644 --- a/test_fms/fms2_io/test_domain_io.F90 +++ b/test_fms/fms2_io/test_domain_io.F90 @@ -46,7 +46,7 @@ program test_domain_read integer :: xhalo = 3 !< Number of halo points in X integer :: yhalo = 2 !< Number of halo points in Y integer :: nz = 2 !< Number of points in the z dimension - character(len=20) :: filename="test.nc" !< Name of the file + character(len=32) :: filename="test.nc" !< Name of the file logical :: use_edges=.false. !< Use North and East domain positions integer :: ndim4 !< Number of points in dim4 @@ -64,7 +64,7 @@ program test_domain_read namelist /test_domain_io_nml/ layout, io_layout, nx, ny, nz, mask_table, xhalo, yhalo, nz, filename, use_edges - call fms_init + call fms_init() read(input_nml_file, nml=test_domain_io_nml, iostat=io) ierr = check_nml_error(io, 'test_domain_io_nml') @@ -134,7 +134,7 @@ program test_domain_read call close_file(fileobj) endif - call fms_end + call fms_end() contains @@ -146,10 +146,10 @@ program test_domain_read character(len=*), intent(in) :: dimension_names(:) !< dimension names integer, intent(in) :: ndim !< Number of dimension - call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i8", "int", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i4", "int64", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r8", "double", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int64", dimension_names(1:ndim)) end subroutine register_field_wrapper !> @brief Allocates the variable to be the size of data compute domain for x and y -- 2.11.4.GIT