Skip to content

Commit

Permalink
fix: replacing cray pointers with fortran pointers in mpp_scatter and…
Browse files Browse the repository at this point in the history
… gather (#1312)
  • Loading branch information
laurenchilutti authored Aug 17, 2023
1 parent e154315 commit 8d75797
Show file tree
Hide file tree
Showing 6 changed files with 51 additions and 45 deletions.
24 changes: 12 additions & 12 deletions fms2_io/include/compressed_write.inc
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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))
Expand Down
29 changes: 16 additions & 13 deletions mpp/include/mpp_gather.fh
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
19 changes: 11 additions & 8 deletions mpp/include/mpp_scatter.fh
Original file line number Diff line number Diff line change
Expand Up @@ -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 !<PE list of target pes,
!! must be in monotonic increasing order
MPP_TYPE_, dimension(is:ie,js:je), intent(inout) :: array_seg !< 2D array of output data
MPP_TYPE_, dimension(:,:), intent(in) :: data !< 2D array of input data
MPP_TYPE_, dimension(is:ie,js:je), target, intent(inout) :: array_seg !< 2D array of output data
MPP_TYPE_, dimension(:,:), contiguous, target, intent(in) :: data !< 2D array of input data
logical, intent(in) :: is_root_pe !< true if calling from root
integer, optional, intent(in) :: ishift, jshift !< Offsets of array elements

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)
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_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, &
ishift, jshift)
Expand Down
2 changes: 1 addition & 1 deletion test_fms/fms2_io/test_bc_restart.sh
Original file line number Diff line number Diff line change
Expand Up @@ -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
'
Expand Down
8 changes: 4 additions & 4 deletions test_fms/fms2_io/test_compressed_writes.F90
Original file line number Diff line number Diff line change
Expand Up @@ -112,10 +112,10 @@ subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim)
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
Expand Down
14 changes: 7 additions & 7 deletions test_fms/fms2_io/test_domain_io.F90
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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')
Expand Down Expand Up @@ -134,7 +134,7 @@ program test_domain_read

call close_file(fileobj)
endif
call fms_end
call fms_end()

contains

Expand All @@ -146,10 +146,10 @@ subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim)
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
Expand Down

0 comments on commit 8d75797

Please sign in to comment.