diff --git a/.github/workflows/github_autotools_intel.yml b/.github/workflows/github_autotools_intel.yml index 0b9c5b7d64..dcebb912e8 100644 --- a/.github/workflows/github_autotools_intel.yml +++ b/.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 diff --git a/drifters/cloud_interpolator.F90 b/drifters/cloud_interpolator.F90 index f83f66274e..ef2ca004b2 100644 --- a/drifters/cloud_interpolator.F90 +++ b/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 !=============================================================================== !> @} diff --git a/drifters/drifters.F90 b/drifters/drifters.F90 index eac1d6cbd8..2afd7068ac 100644 --- a/drifters/drifters.F90 +++ b/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 diff --git a/drifters/drifters_comm.F90 b/drifters/drifters_comm.F90 index 5319e19934..e94e2a7f23 100644 --- a/drifters/drifters_comm.F90 +++ b/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 !=============================================================================== diff --git a/drifters/drifters_core.F90 b/drifters/drifters_core.F90 index c25dd85e54..8d35d05cf4 100644 --- a/drifters/drifters_core.F90 +++ b/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 !############################################################################### !> @} diff --git a/drifters/drifters_input.F90 b/drifters/drifters_input.F90 index 0327f67053..157d12b215 100644 --- a/drifters/drifters_input.F90 +++ b/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 diff --git a/drifters/drifters_io.F90 b/drifters/drifters_io.F90 index 3592da9603..e9754f4487 100644 --- a/drifters/drifters_io.F90 +++ b/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 diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc index cd2919c162..e284a0892a 100644 --- a/fms2_io/include/compressed_write.inc +++ b/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)) 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/mpp/include/mpp_util_mpi.inc b/mpp/include/mpp_util_mpi.inc index ef9443783a..7d235be83b 100644 --- a/mpp/include/mpp_util_mpi.inc +++ b/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 diff --git a/test_fms/drifters/test_cloud_interpolator.F90 b/test_fms/drifters/test_cloud_interpolator.F90 index e11d480587..204e5d545e 100644 --- a/test_fms/drifters/test_cloud_interpolator.F90 +++ b/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 diff --git a/test_fms/drifters/test_drifters.F90 b/test_fms/drifters/test_drifters.F90 index 0bfe4bb685..ab6cb91c89 100644 --- a/test_fms/drifters/test_drifters.F90 +++ b/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) diff --git a/test_fms/drifters/test_drifters_comm.F90 b/test_fms/drifters/test_drifters_comm.F90 index 25b1e532d3..85108fa4d2 100644 --- a/test_fms/drifters/test_drifters_comm.F90 +++ b/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 diff --git a/test_fms/drifters/test_drifters_core.F90 b/test_fms/drifters/test_drifters_core.F90 index b2b93a5e82..51e81efc72 100644 --- a/test_fms/drifters/test_drifters_core.F90 +++ b/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 diff --git a/test_fms/drifters/test_drifters_input.F90 b/test_fms/drifters/test_drifters_input.F90 index 64a887856d..297b751493 100644 --- a/test_fms/drifters/test_drifters_input.F90 +++ b/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 diff --git a/test_fms/drifters/test_drifters_io.F90 b/test_fms/drifters/test_drifters_io.F90 index 989141b8f7..f74e8cb500 100644 --- a/test_fms/drifters/test_drifters_io.F90 +++ b/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 diff --git a/test_fms/drifters/test_quicksort.F90 b/test_fms/drifters/test_quicksort.F90 index 4ad7701a50..04cb268112 100644 --- a/test_fms/drifters/test_quicksort.F90 +++ b/test_fms/drifters/test_quicksort.F90 @@ -19,9 +19,11 @@ !*********************************************************************** program test_quicksort +#ifdef use_drifters implicit none integer :: list(16) = (/6, 2, 3, 4, 1, 45, 3432, 3245, 32545, 66555, 32, 1,3, -43254, 324, 54/) print *,'before list=', list call qksrt_quicksort(size(list), list, 1, size(list)) print *,'after list=', list +#endif end program test_quicksort 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_compressed_writes.F90 b/test_fms/fms2_io/test_compressed_writes.F90 index b905be70d7..38d44f6392 100644 --- a/test_fms/fms2_io/test_compressed_writes.F90 +++ b/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 diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 index 07a3e2845a..5b00d8c9fe 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 @@ -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