From 4ee15e7ead6b8eabdad30a356cea1faa70ce3d5e Mon Sep 17 00:00:00 2001 From: Lauren Chilutti Date: Mon, 31 Jul 2023 14:55:10 -0400 Subject: [PATCH] replacing cray pointers with fortran pointers in mpp_scatter and mpp_gather. Only pointing if on root pe for gather and scatter. Enlarging the size of filename in test_domain_io.F90 to allow for longer filenames. Consistently creating input nml in test_bc_restart.sh --- 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_domain_io.F90 | 6 +++--- 4 files changed, 31 insertions(+), 25 deletions(-) diff --git a/mpp/include/mpp_gather.fh b/mpp/include/mpp_gather.fh index 17b09c0312..8ead643f3a 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 4223f79c39..fce54f5a78 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 07b0081c8f..faac53e0cb 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_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 index 07a3e2845a..506277107a 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