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
NOAA-GFDL · Jul 31, 2023 · 4ee15e7 · 4ee15e7
1 parent 0efc2e5
commit 4ee15e7
Show file tree

Hide file tree

Showing 4 changed files with 31 additions and 25 deletions.
diff --git 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
@@ -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)

diff --git 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
@@ -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