diff --git a/mpp/include/mpp_sum.inc b/mpp/include/mpp_sum.inc index d81125a7a..b7d1525c4 100644 --- a/mpp/include/mpp_sum.inc +++ b/mpp/include/mpp_sum.inc @@ -41,13 +41,12 @@ !####################################################################### !> Sums 2d array across pes subroutine MPP_SUM_2D_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:) !< 2d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:) !< 2d array to sum integer, intent(in) :: length !< amount of indices in given 2d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:) call mpp_sum( a1D, length, pelist ) return @@ -56,13 +55,12 @@ !####################################################################### !> Sums 3d array across pes subroutine MPP_SUM_3D_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:) !< 3d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:) !< 3d array to sum integer, intent(in) :: length !< amount of indices in given 3d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:) call mpp_sum( a1D, length, pelist ) return @@ -71,13 +69,12 @@ !####################################################################### !> Sums 4d array across pes subroutine MPP_SUM_4D_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:,:) !< 4d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:,:) !< 4d array to sum integer, intent(in) :: length !< amount of indices in given 4d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:,:) call mpp_sum( a1D, length, pelist ) return @@ -86,13 +83,12 @@ !####################################################################### !> Sums 5d array across pes subroutine MPP_SUM_5D_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:,:,:) !< 5d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:,:,:) !< 5d array to sum integer, intent(in) :: length !< amount of indices in given 5d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:,:,:) call mpp_sum( a1D, length, pelist ) return diff --git a/mpp/include/mpp_sum_ad.inc b/mpp/include/mpp_sum_ad.inc index ad0713785..f78f38baa 100644 --- a/mpp/include/mpp_sum_ad.inc +++ b/mpp/include/mpp_sum_ad.inc @@ -42,13 +42,12 @@ !####################################################################### !> Sums 2d array across pes subroutine MPP_SUM_2D_AD_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:) !< 2d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:) !< 2d array to sum integer, intent(in) :: length !< amount of indices in given 2d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:) call mpp_sum_ad( a1D, length, pelist ) return @@ -57,13 +56,12 @@ !####################################################################### !> Sums 3d array across pes subroutine MPP_SUM_3D_AD_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:) !< 3d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:) !< 3d array to sum integer, intent(in) :: length !< amount of indices in given 3d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:) call mpp_sum_ad( a1D, length, pelist ) return @@ -72,13 +70,12 @@ !####################################################################### !> Sums 4d array across pes subroutine MPP_SUM_4D_AD_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:,:) !< 4d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:,:) !< 4d array to sum integer, intent(in) :: length !< amount of indices in given 4d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:,:) call mpp_sum_ad( a1D, length, pelist ) return @@ -87,13 +84,12 @@ !####################################################################### !> Sums 5d array across pes subroutine MPP_SUM_5D_AD_( a, length, pelist ) - MPP_TYPE_, intent(inout) :: a(:,:,:,:,:) !< 5d array to sum + MPP_TYPE_, target, contiguous, intent(inout) :: a(:,:,:,:,:) !< 5d array to sum integer, intent(in) :: length !< amount of indices in given 5d array integer, intent(in), optional :: pelist(:) !< pelist to calculate sum across - MPP_TYPE_ :: a1D(length) + MPP_TYPE_, pointer :: a1D(:) - pointer( ptr, a1D ) - ptr = LOC(a) + a1D(1:length) => a(:,:,:,:,:) call mpp_sum_ad( a1D, length, pelist ) return diff --git a/mpp/include/mpp_transmit.inc b/mpp/include/mpp_transmit.inc index 1c445ed0c..84354d8e1 100644 --- a/mpp/include/mpp_transmit.inc +++ b/mpp/include/mpp_transmit.inc @@ -31,22 +31,21 @@ subroutine MPP_TRANSMIT_SCALAR_( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, & recv_request, send_request) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc integer, intent(in) :: to_pe, from_pe - MPP_TYPE_, intent(in) :: put_data - MPP_TYPE_, intent(out) :: get_data + MPP_TYPE_, target, intent(in) :: put_data + MPP_TYPE_, target, intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len - MPP_TYPE_ :: put_data1D(1), get_data1D(1) - pointer( ptrp, put_data1D ) - pointer( ptrg, get_data1D ) + MPP_TYPE_, pointer :: put_data1D(:), get_data1D(:) get_data = MPP_TYPE_INIT_VALUE - ptrp = LOC(put_data) - ptrg = LOC(get_data) + call c_f_pointer(c_loc(put_data), put_data1D, [1]) + call c_f_pointer(c_loc(get_data), get_data1D, [1]) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call MPP_TRANSMIT_ ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & @@ -58,19 +57,17 @@ subroutine MPP_TRANSMIT_2D_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, & recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe - MPP_TYPE_, intent(in) :: put_data(:,:) - MPP_TYPE_, intent(out) :: get_data(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: put_data(:,:) + MPP_TYPE_, target, contiguous, intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request - MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len) + MPP_TYPE_, pointer :: put_data1D(:), get_data1D(:) - pointer( ptrp, put_data1D ) - pointer( ptrg, get_data1D ) get_data = MPP_TYPE_INIT_VALUE - ptrp = LOC(put_data) - ptrg = LOC(get_data) + put_data1D(1:put_len) => put_data(:,:) + get_data1D(1:get_len) => get_data(:,:) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) @@ -80,19 +77,17 @@ subroutine MPP_TRANSMIT_3D_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, & recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe - MPP_TYPE_, intent(in) :: put_data(:,:,:) - MPP_TYPE_, intent(out) :: get_data(:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: put_data(:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request - MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len) + MPP_TYPE_, pointer :: put_data1D(:), get_data1D(:) - pointer( ptrp, put_data1D ) - pointer( ptrg, get_data1D ) get_data = MPP_TYPE_INIT_VALUE - ptrp = LOC(put_data) - ptrg = LOC(get_data) + put_data1D(1:put_len) => put_data(:,:,:) + get_data1D(1:get_len) => get_data(:,:,:) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) @@ -102,19 +97,17 @@ subroutine MPP_TRANSMIT_4D_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, & recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe - MPP_TYPE_, intent(in) :: put_data(:,:,:,:) - MPP_TYPE_, intent(out) :: get_data(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: put_data(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request - MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len) + MPP_TYPE_, pointer :: put_data1D(:), get_data1D(:) - pointer( ptrp, put_data1D ) - pointer( ptrg, get_data1D ) get_data = MPP_TYPE_INIT_VALUE - ptrp = LOC(put_data) - ptrg = LOC(get_data) + put_data1D(1:put_len) => put_data(:,:,:,:) + get_data1D(1:get_len) => get_data(:,:,:,:) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) @@ -124,19 +117,17 @@ subroutine MPP_TRANSMIT_5D_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, & recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe - MPP_TYPE_, intent(in) :: put_data(:,:,:,:,:) - MPP_TYPE_, intent(out) :: get_data(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: put_data(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request - MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len) + MPP_TYPE_, pointer :: put_data1D(:), get_data1D(:) - pointer( ptrp, put_data1D ) - pointer( ptrg, get_data1D ) get_data = MPP_TYPE_INIT_VALUE - ptrp = LOC(put_data) - ptrg = LOC(get_data) + put_data1D(1:put_len) => put_data(:,:,:,:,:) + get_data1D(1:get_len) => get_data(:,:,:,:,:) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) @@ -172,21 +163,21 @@ subroutine MPP_RECV_SCALAR_( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc integer, intent(in) :: from_pe - MPP_TYPE_, intent(out) :: get_data + MPP_TYPE_, target, intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len - MPP_TYPE_ :: get_data1D(1) + MPP_TYPE_, pointer :: get_data1D(:) MPP_TYPE_ :: dummy(1) - pointer( ptr, get_data1D ) get_data = MPP_TYPE_INIT_VALUE - ptr = LOC(get_data) + call c_f_pointer(c_loc(get_data), get_data1D, [1]) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request ) @@ -194,17 +185,17 @@ subroutine MPP_SEND_SCALAR_( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc integer, intent(in) :: to_pe - MPP_TYPE_, intent(in) :: put_data + MPP_TYPE_, target, intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len - MPP_TYPE_ :: put_data1D(1) + MPP_TYPE_, pointer :: put_data1D(:) MPP_TYPE_ :: dummy(1) - pointer( ptr, put_data1D ) - ptr = LOC(put_data) + call c_f_pointer(c_loc(put_data), put_data1D, [1]) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) @@ -305,14 +296,13 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_BROADCAST_SCALAR_( broadcast_data, from_pe, pelist ) - MPP_TYPE_, intent(inout) :: broadcast_data + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc + MPP_TYPE_, target, intent(inout) :: broadcast_data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) - MPP_TYPE_ :: data1D(1) - - pointer( ptr, data1D ) + MPP_TYPE_, pointer :: data1D(:) - ptr = LOC(broadcast_data) + call c_f_pointer(c_loc(broadcast_data), data1D, [1]) call MPP_BROADCAST_( data1D, 1, from_pe, pelist ) return @@ -322,13 +312,12 @@ !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: broadcast_data(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: broadcast_data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) - MPP_TYPE_ :: data1D(length) + MPP_TYPE_, pointer :: data1D(:) - pointer( ptr, data1D ) - ptr = LOC(broadcast_data) + data1D(1:length) => broadcast_data(:,:) call mpp_broadcast( data1D, length, from_pe, pelist ) return @@ -338,13 +327,12 @@ !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: broadcast_data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) - MPP_TYPE_ :: data1D(length) + MPP_TYPE_, pointer :: data1D(:) - pointer( ptr, data1D ) - ptr = LOC(broadcast_data) + data1D(1:length) => broadcast_data(:,:,:) call mpp_broadcast( data1D, length, from_pe, pelist ) return @@ -354,13 +342,12 @@ !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: broadcast_data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) - MPP_TYPE_ :: data1D(length) + MPP_TYPE_, pointer :: data1D(:) - pointer( ptr, data1D ) - ptr = LOC(broadcast_data) + data1D(1:length) => broadcast_data(:,:,:,:) call mpp_broadcast( data1D, length, from_pe, pelist ) return @@ -370,13 +357,12 @@ !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: broadcast_data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) - MPP_TYPE_ :: data1D(length) + MPP_TYPE_, pointer :: data1D(:) - pointer( ptr, data1D ) - ptr = LOC(broadcast_data) + data1D(1:length) => broadcast_data(:,:,:,:,:) call mpp_broadcast( data1D, length, from_pe, pelist ) return diff --git a/mpp/include/mpp_transmit_mpi.fh b/mpp/include/mpp_transmit_mpi.fh index df7b4f262..364ff6824 100644 --- a/mpp/include/mpp_transmit_mpi.fh +++ b/mpp/include/mpp_transmit_mpi.fh @@ -37,10 +37,11 @@ !!caller is responsible for completion checks (mpp_sync_self) before and after subroutine MPP_TRANSMIT_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, & & send_request ) + use, intrinsic :: iso_c_binding, only: c_loc, c_associated integer, intent(in) :: put_len, to_pe, get_len, from_pe - MPP_TYPE_, intent(in) :: put_data(*) - MPP_TYPE_, intent(out) :: get_data(*) + MPP_TYPE_, target, intent(in) :: put_data(*) + MPP_TYPE_, target, intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request @@ -89,7 +90,7 @@ if(from_pe.LT.0 .OR. from_pe.GE.npes) call mpp_error(FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.') if(put_len.GT.get_len) call mpp_error(FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.') if(pe.EQ.from_pe)then - if( LOC(get_data).NE.LOC(put_data) )then + if( .not.c_associated(c_loc(get_data),c_loc(put_data)) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i)