Merge branch 'NOAA-GFDL:main' into intel-ci-new-compilers

.github/workflows/github_autotools_intel.yml

@@ -2,13 +2,16 @@ on: pull_request
 jobs:
   build-dependencies:
     runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        io-flag: ["--disable-deprecated-io", "--enable-deprecated-io"]
     container:
       image: intel/oneapi-hpckit:2023.1.0-devel-ubuntu20.04
       env:
         CC: mpiicc
         FC: mpiifort
         CFLAGS:  "-I/libs/include"
-        FCFLAGS: "-I/libs/include -g -traceback"
+        FCFLAGS: "-I/libs/include -g -traceback ${{ matrix.io-flag }}"
         LDFLAGS: "-L/libs/lib"
     steps:
     - name: Cache dependencies

drifters/cloud_interpolator.F90

@@ -25,6 +25,7 @@
 !> @addtogroup cloud_interpolator_mod
 !> @{
 MODULE cloud_interpolator_mod
+#ifdef use_drifters
   implicit none
   private
 
@@ -284,6 +285,7 @@ pure subroutine cld_ntrp_get_cell_values(nsizes, fnodes, indices, fvals, ier)
 
   end subroutine cld_ntrp_get_cell_values
 
+#endif
 end MODULE cloud_interpolator_mod
 !===============================================================================
 !> @}

drifters/drifters.F90

@@ -60,6 +60,7 @@
 !> @addtogroup drifters_mod
 !> @{
 module drifters_mod
+#ifdef use_drifters
 
 #ifdef _SERIAL
 
@@ -947,7 +948,7 @@ subroutine drifters_reset_rk4(self, ermesg)
     endif
 
   end subroutine drifters_reset_rk4
-
+#endif
 end module drifters_mod
 !> @}
 ! close documentation grouping

drifters/drifters_comm.F90

@@ -23,6 +23,7 @@
 !> @brief Routines and types to update drifter positions across processor domains
 
 module drifters_comm_mod
+#ifdef use_drifters
 
 #ifdef _SERIAL
 
@@ -769,7 +770,7 @@ subroutine drifters_comm_gather(self, drfts, dinp, &
 
   end subroutine drifters_comm_gather
 
-
+#endif
 end module drifters_comm_mod
 
 !===============================================================================

drifters/drifters_core.F90

@@ -21,6 +21,7 @@
 !> @brief Handles the mechanics for adding and removing drifters
 
 module drifters_core_mod
+#ifdef use_drifters
   use platform_mod
   implicit none
   private
@@ -272,7 +273,7 @@ subroutine drifters_core_print(self1, ermesg1)
 
   end subroutine drifters_core_print
 
-
+#endif
 end module drifters_core_mod
 !###############################################################################
 !> @}

drifters/drifters_input.F90

@@ -23,6 +23,7 @@
 !> @addtogroup drifters_input_mod
 !> @{
 module drifters_input_mod
+#ifdef use_drifters
   implicit none
   private
 
@@ -444,7 +445,7 @@ subroutine drifters_input_save(self, filename, geolon, geolat, ermesg)
          & //nf_strerror(ier)
 
   end subroutine drifters_input_save
-
+#endif
 end module drifters_input_mod
 !> @}
 ! close documentation grouping

drifters/drifters_io.F90

@@ -23,6 +23,7 @@
 !> @addtogroup drifters_io_mod
 !> @{
 module drifters_io_mod
+#ifdef use_drifters
 
   use netcdf
   use netcdf_nf_data
@@ -307,7 +308,7 @@ subroutine drifters_io_write(self, time, np, nd, nf, ids, positions, fields, erm
     self%it_id = self%it_id + np
 
   end subroutine drifters_io_write
-
+#endif
 end module drifters_io_mod
 !> @}
 ! close documentation grouping

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)

mpp/include/mpp_util_mpi.inc

@@ -93,7 +93,6 @@ function get_peset(pelist)
   integer, intent(in), optional :: pelist(:)
   integer                       :: errunit
   integer                       :: i, n
-  integer,          allocatable :: sorted(:)
 
   if( .NOT.PRESENT(pelist) )then !set it to current_peset_num
      get_peset = current_peset_num; return
@@ -106,17 +105,14 @@ function get_peset(pelist)
     enddo
   endif
 
-  allocate( sorted(size(pelist(:))) )
-  sorted = pelist
   errunit = stderr()
   if( debug )write( errunit,* )'pelist=', pelist
 
   !find if this array matches any existing peset
   do i = 1,peset_num
      if( debug )write( errunit,'(a,3i6)' )'pe, i, peset_num=', pe, i, peset_num
-     if( size(sorted(:)).EQ.size(peset(i)%list(:)) )then
-        if( ALL(sorted.EQ.peset(i)%list) )then
-           deallocate(sorted)
+     if( size(pelist(:)).EQ.size(peset(i)%list(:)) )then
+        if( ALL(pelist.EQ.peset(i)%list) )then
            get_peset = i; return
         end if
      end if
@@ -126,14 +122,13 @@ function get_peset(pelist)
   if( peset_num > current_peset_max ) call expand_peset()
   i = peset_num             !shorthand
   !create list
-  allocate( peset(i)%list(size(sorted(:))) )
-  peset(i)%list(:) = sorted(:)
-  peset(i)%count = size(sorted(:))
+  allocate( peset(i)%list(size(pelist(:))) )
+  peset(i)%list(:) = pelist(:)
+  peset(i)%count = size(pelist(:))
 
-  call MPI_GROUP_INCL( peset(current_peset_num)%group, size(sorted(:)), sorted-mpp_root_pe(), peset(i)%group, error )
+  call MPI_GROUP_INCL( peset(current_peset_num)%group, size(pelist(:)), pelist-mpp_root_pe(), peset(i)%group, error )
   call MPI_COMM_CREATE_GROUP(peset(current_peset_num)%id, peset(i)%group, &
                              DEFAULT_TAG, peset(i)%id, error )
-  deallocate(sorted)
   get_peset = i
 
   return

test_fms/drifters/test_cloud_interpolator.F90

@@ -18,6 +18,7 @@
 !***********************************************************************
 
 program test_cloud_interpolator
+#ifdef use_drifters
   use cloud_interpolator_mod
   use mpp_mod, only : mpp_error, FATAL, stdout, mpp_init, mpp_exit
 
@@ -215,4 +216,5 @@ subroutine test_get_node_values
 
 end subroutine test_get_node_values
 
+#endif
   end program test_cloud_interpolator

test_fms/drifters/test_drifters.F90

@@ -18,6 +18,7 @@
 !***********************************************************************
 
 program test_drifters
+#ifdef use_drifters
 
 !* contents of input file: drifters_inp_test_3d.nc
 !!$netcdf drifters_inp_test_3d {
@@ -336,7 +337,7 @@ program test_drifters
 !#ifndef _SERIAL
   call mpp_exit
 !#endif
-
+#endif
 end program test_drifters
 
 subroutine my_error_handler(mesg)

test_fms/drifters/test_drifters_comm.F90

@@ -19,6 +19,7 @@
 !**********************************************************************
 
 program test_drifters_comm
+#ifdef use_drifters
 
   use drifters_core_mod
   use drifters_comm_mod
@@ -143,4 +144,5 @@ program test_drifters_comm
   call mpp_domains_exit
   call mpp_exit
 
+#endif
 end program test_drifters_comm

test_fms/drifters/test_drifters_core.F90

@@ -19,6 +19,7 @@
 !**********************************************************************
 
 program test_drifters_core
+#ifdef use_drifters
 
   use drifters_core_mod
   use fms_mod, only : fms_init, fms_end
@@ -111,4 +112,5 @@ program test_drifters_core
 !!$     print *,'Sucessful test ier=', ier
 !!$  end if
   call fms_end()
+#endif
 end program test_drifters_core

test_fms/drifters/test_drifters_input.F90

@@ -19,6 +19,7 @@
 !***********************************************************************
 
 program test_drifters_input
+#ifdef use_drifters
   use drifters_input_mod
   use fms_mod, only : fms_init, fms_end
   use mpp_mod, only : mpp_error, FATAL, stdout
@@ -54,4 +55,5 @@ program test_drifters_input
   call drifters_input_del(obj, ermesg)
 
   call fms_end()
+#endif
 end program test_drifters_input

test_fms/drifters/test_drifters_io.F90

@@ -18,6 +18,7 @@
 !***********************************************************************
 
 program test_drifters_io
+#ifdef use_drifters
 
   use drifters_io_mod
   use mpp_mod, only : mpp_error, FATAL, stdout, mpp_init, mpp_exit
@@ -156,4 +157,5 @@ program test_drifters_io
       call mpp_error(FATAL, ermesg)
   endif
   call mpp_exit()
+#endif
 end program test_drifters_io