fix: replacing cray pointers with fortran pointers in mpp_scatter and…

… gather (#1403)

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))

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)

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)

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
 '

test_fms/fms2_io/test_compressed_writes.F90

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

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