diff --git a/cmake/compiler_flags_GNU_Fortran.cmake b/cmake/compiler_flags_GNU_Fortran.cmake index cffa72cbf6..83bc23e9e4 100644 --- a/cmake/compiler_flags_GNU_Fortran.cmake +++ b/cmake/compiler_flags_GNU_Fortran.cmake @@ -3,7 +3,7 @@ set(r8_flags "-fdefault-real-8 -fdefault-double-8") # Fortran flags for 64BIT pr set(r4_flags "-fdefault-real-4") # Fortran flags for 32BIT precision # GNU Fortran -set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fcray-pointer -fallow-argument-mismatch -ffree-line-length-none") +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-argument-mismatch -ffree-line-length-none") set(CMAKE_Fortran_FLAGS_RELEASE "-O2") set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -g") diff --git a/cmake/compiler_flags_Intel_Fortran.cmake b/cmake/compiler_flags_Intel_Fortran.cmake index eb73f25600..fb60cc756d 100644 --- a/cmake/compiler_flags_Intel_Fortran.cmake +++ b/cmake/compiler_flags_Intel_Fortran.cmake @@ -3,12 +3,11 @@ set(r4_flags "-real-size 32") # Fortran flags for 32BIT precision set(r8_flags "-real-size 64") # Fortran flags for 64BIT precision # Minimal set of flags for stand release and debug build types -set(CMAKE_Fortran_FLAGS "${RELEASE} -safe-cray-ptr") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS_DEBUG "-g -O0") # ufs flags to reproduce past behavior -set(ufs_flags_base "${CMAKE_Fortran_FLAGS} -fpp -fno-alias -auto -safe-cray-ptr -ftz -assume byterecl -align array64byte -nowarn -sox -traceback") +set(ufs_flags_base "${CMAKE_Fortran_FLAGS} -fpp -fno-alias -auto -ftz -assume byterecl -align array64byte -nowarn -sox -traceback") set(CMAKE_Fortran_FLAGS_RELEASE "${ufs_flags_base} -O2 -debug minimal -fp-model source -nowarn -qoverride-limits -qno-opt-dynamic-align -qopt-prefetch=3") set(CMAKE_Fortran_FLAGS_DEBUGUFS "${ufs_flags_base} -g -O0 -check -check noarg_temp_created -check nopointer -warn -warn noerrors -fpe0 -ftrapuv") diff --git a/include/fms_platform.h b/include/fms_platform.h index 265d417477..5c0e906b87 100644 --- a/include/fms_platform.h +++ b/include/fms_platform.h @@ -25,14 +25,16 @@ !Set type kinds. #ifdef PORTABLE_KINDS use,intrinsic :: iso_fortran_env, only: real128 -use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & - c_int32_t,c_int16_t,c_intptr_t +use,intrinsic :: iso_c_binding, only: c_double,c_float, & + c_int64_t,c_int32_t,c_int16_t, & + c_int8_t,c_intptr_t #define QUAD_KIND real128 #define DOUBLE_KIND c_double #define FLOAT_KIND c_float #define LONG_KIND c_int64_t #define INT_KIND c_int32_t #define SHORT_KIND c_int16_t +#define BYTE_KIND c_int8_t #define POINTER_KIND c_intptr_t #else !These values are not necessarily portable. @@ -42,6 +44,7 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & #define LONG_KIND 8 #define INT_KIND 4 #define SHORT_KIND 2 +#define BYTE_KIND 1 #define POINTER_KIND 8 !DEC$ MESSAGE:'Using 8-byte addressing' #endif diff --git a/mpp/include/group_update_pack.inc b/mpp/include/group_update_pack.inc index de08b89e56..bdc8d415cc 100644 --- a/mpp/include/group_update_pack.inc +++ b/mpp/include/group_update_pack.inc @@ -17,9 +17,10 @@ !*********************************************************************** if( group%k_loop_inside ) then -!$OMP parallel do default(none) shared(npack,group,ptr,nvector,ksize,buffer_start_pos) & +!$OMP parallel do default(none) & +!$OMP shared(npack,group,buffer,nvector,ksize,buffer_start_pos,shape_f,shape_x,shape_y) & !$OMP private(buffer_pos,pos,m,is,ie,js,je,rotation, & -!$OMP ptr_field, ptr_fieldx, ptr_fieldy,n,k) +!$OMP field,fieldx,fieldy,tmpptr,n,k) do n = 1, npack buffer_pos = group%pack_buffer_pos(n) + buffer_start_pos pos = buffer_pos @@ -30,7 +31,8 @@ if( group%k_loop_inside ) then select case( rotation ) case(ZERO) do l=1, group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -42,7 +44,8 @@ if( group%k_loop_inside ) then enddo case( MINUS_NINETY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do k = 1, ksize do i = is, ie do j = je, js, -1 @@ -54,7 +57,8 @@ if( group%k_loop_inside ) then end do case( NINETY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do k = 1, ksize do i = ie, is, -1 do j = js, je @@ -66,7 +70,8 @@ if( group%k_loop_inside ) then end do case( ONE_HUNDRED_EIGHTY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do k = 1, ksize do j = je, js, -1 do i = ie, is, -1 @@ -81,7 +86,8 @@ if( group%k_loop_inside ) then select case( rotation ) case(ZERO) do l=1, nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -94,7 +100,8 @@ if( group%k_loop_inside ) then case( MINUS_NINETY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do i = is, ie do j = je, js, -1 @@ -106,7 +113,8 @@ if( group%k_loop_inside ) then end do else do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do i = is, ie do j = je, js, -1 @@ -119,7 +127,8 @@ if( group%k_loop_inside ) then end if case( NINETY ) do l=1, nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do i = ie, is, -1 do j = js, je @@ -132,7 +141,8 @@ if( group%k_loop_inside ) then case( ONE_HUNDRED_EIGHTY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do j = je, js, -1 do i = ie, is, -1 @@ -144,7 +154,8 @@ if( group%k_loop_inside ) then end do else do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do j = je, js, -1 do i = ie, is, -1 @@ -160,7 +171,8 @@ if( group%k_loop_inside ) then select case( rotation ) case(ZERO) do l=1, nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -172,7 +184,8 @@ if( group%k_loop_inside ) then end do case( MINUS_NINETY ) do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do i = is, ie do j = je, js, -1 @@ -185,7 +198,8 @@ if( group%k_loop_inside ) then case( NINETY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1, nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do i = ie, is, -1 do j = js, je @@ -197,7 +211,8 @@ if( group%k_loop_inside ) then end do else do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do i = ie, is, -1 do j = js, je @@ -211,7 +226,8 @@ if( group%k_loop_inside ) then case( ONE_HUNDRED_EIGHTY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do j = je, js, -1 do i = ie, is, -1 @@ -223,7 +239,8 @@ if( group%k_loop_inside ) then end do else do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do j = je, js, -1 do i = ie, is, -1 @@ -238,9 +255,10 @@ if( group%k_loop_inside ) then endif enddo else -!$OMP parallel do default(none) shared(npack,group,ptr,nvector,ksize,buffer_start_pos) & +!$OMP parallel do default(none) & +!$OMP shared(npack,group,buffer,nvector,ksize,buffer_start_pos,shape_f,shape_x,shape_y) & !$OMP private(buffer_pos,pos,m,is,ie,js,je,rotation, & -!$OMP ptr_field, ptr_fieldx, ptr_fieldy,n,k) +!$OMP field,fieldx,fieldy,tmpptr,n,k) do nk = 1, npack*ksize n = (nk-1)/ksize + 1 k = mod((nk-1), ksize) + 1 @@ -253,7 +271,8 @@ else select case( rotation ) case(ZERO) do l=1, group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do j = js, je do i = is, ie pos = pos + 1 @@ -263,7 +282,8 @@ else enddo case( MINUS_NINETY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do i = is, ie do j = je, js, -1 pos = pos + 1 @@ -273,7 +293,8 @@ else end do case( NINETY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do i = ie, is, -1 do j = js, je pos = pos + 1 @@ -283,7 +304,8 @@ else end do case( ONE_HUNDRED_EIGHTY ) do l=1,group%nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do j = je, js, -1 do i = ie, is, -1 pos = pos + 1 @@ -296,7 +318,8 @@ else select case( rotation ) case(ZERO) do l=1, nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do j = js, je do i = is, ie pos = pos + 1 @@ -307,7 +330,8 @@ else case( MINUS_NINETY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do i = is, ie do j = je, js, -1 pos = pos + 1 @@ -317,7 +341,8 @@ else end do else do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do i = is, ie do j = je, js, -1 pos = pos + 1 @@ -328,7 +353,8 @@ else end if case( NINETY ) do l=1, nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do i = ie, is, -1 do j = js, je pos = pos + 1 @@ -339,7 +365,8 @@ else case( ONE_HUNDRED_EIGHTY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do j = je, js, -1 do i = ie, is, -1 pos = pos + 1 @@ -349,7 +376,8 @@ else end do else do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do j = je, js, -1 do i = ie, is, -1 pos = pos + 1 @@ -363,7 +391,8 @@ else select case( rotation ) case(ZERO) do l=1, nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do j = js, je do i = is, ie pos = pos + 1 @@ -373,7 +402,8 @@ else end do case( MINUS_NINETY ) do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do i = is, ie do j = je, js, -1 pos = pos + 1 @@ -384,7 +414,8 @@ else case( NINETY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1, nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do i = ie, is, -1 do j = js, je pos = pos + 1 @@ -394,7 +425,8 @@ else end do else do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do i = ie, is, -1 do j = js, je pos = pos + 1 @@ -406,7 +438,8 @@ else case( ONE_HUNDRED_EIGHTY ) if( BTEST(group%flags_v,SCALAR_BIT) ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do j = je, js, -1 do i = ie, is, -1 pos = pos + 1 @@ -416,7 +449,8 @@ else end do else do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do j = je, js, -1 do i = ie, is, -1 pos = pos + 1 diff --git a/mpp/include/group_update_unpack.inc b/mpp/include/group_update_unpack.inc index 49fb2555ce..7164eec153 100644 --- a/mpp/include/group_update_unpack.inc +++ b/mpp/include/group_update_unpack.inc @@ -17,9 +17,10 @@ !*********************************************************************** if( group%k_loop_inside ) then -!$OMP parallel do default(none) shared(nunpack,group,nscalar,ptr,nvector,ksize,buffer_start_pos) & +!$OMP parallel do default(none) & +!$OMP shared(nunpack,group,nscalar,buffer,nvector,ksize,buffer_start_pos,shape_f,shape_x,shape_y) & !$OMP private(buffer_pos,pos,m,is, ie, js, je,rotation, & -!$OMP ptr_field, ptr_fieldx, ptr_fieldy, n,k ) +!$OMP field, fieldx, fieldy, tmpptr, n,k ) do n = nunpack, 1, -1 buffer_pos = group%unpack_buffer_pos(n) + buffer_start_pos pos = buffer_pos @@ -27,7 +28,8 @@ if( group%k_loop_inside ) then js = group%unpack_js(n); je = group%unpack_je(n) if( group%unpack_type(n) == FIELD_S ) then do l=1,nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -39,7 +41,8 @@ if( group%k_loop_inside ) then end do else if( group%unpack_type(n) == FIELD_X ) then do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -51,7 +54,8 @@ if( group%k_loop_inside ) then end do else if( group%unpack_type(n) == FIELD_Y ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1, ksize do j = js, je do i = is, ie @@ -64,9 +68,10 @@ if( group%k_loop_inside ) then endif enddo else -!$OMP parallel do default(none) shared(nunpack,group,nscalar,ptr,nvector,ksize,buffer_start_pos) & +!$OMP parallel do default(none) & +!$OMP shared(nunpack,group,nscalar,buffer,nvector,ksize,buffer_start_pos,shape_f,shape_x,shape_y) & !$OMP private(buffer_pos,pos,m,is, ie, js, je,rotation, & -!$OMP ptr_field, ptr_fieldx, ptr_fieldy,n,k) +!$OMP field, fieldx, fieldy, tmpptr,n,k) do nk = nunpack*ksize, 1, -1 n = (nk-1)/ksize + 1 k = mod((nk-1), ksize) + 1 @@ -76,7 +81,8 @@ else js = group%unpack_js(n); je = group%unpack_je(n) if( group%unpack_type(n) == FIELD_S ) then do l=1,nscalar ! loop over number of fields - ptr_field = group%addrs_s(l) + call c_f_pointer(group%addrs_s(l), tmpptr, shape=shape_f) + field(group%is_s:group%ie_s,group%js_s:group%je_s, 1:group%ksize_s) => tmpptr do j = js, je do i = is, ie pos = pos + 1 @@ -86,7 +92,8 @@ else end do else if( group%unpack_type(n) == FIELD_X ) then do l=1,nvector ! loop over number of fields - ptr_fieldx = group%addrs_x(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr do j = js, je do i = is, ie pos = pos + 1 @@ -96,7 +103,8 @@ else end do else if( group%unpack_type(n) == FIELD_Y ) then do l=1,nvector ! loop over number of fields - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do j = js, je do i = is, ie pos = pos + 1 diff --git a/mpp/include/mpp_chksum_scalar.fh b/mpp/include/mpp_chksum_scalar.fh index e70ea00feb..c6b104fb65 100644 --- a/mpp/include/mpp_chksum_scalar.fh +++ b/mpp/include/mpp_chksum_scalar.fh @@ -29,20 +29,20 @@ !! result is i8_kind, which will actually be int ifdef no_8byte_integers !! mold and mask_val must be same numBytes, otherwise undefined behavior function MPP_CHKSUM_( var, pelist, mask_val ) - integer(i8_kind) :: MPP_CHKSUM_ - MPP_TYPE_, intent(in) :: var - integer, intent(in), optional :: pelist(:) - integer(i8_kind) :: mold(1) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc + integer(i8_kind) :: MPP_CHKSUM_ + MPP_TYPE_, target, intent(in) :: var + integer, intent(in), optional :: pelist(:) MPP_TYPE_, intent(in), optional :: mask_val - pointer( p, mold ) + integer(i8_kind), pointer :: mold(:) - p = LOC(var) + call c_f_pointer(c_loc(var), mold, [1]) if ( PRESENT(mask_val) ) then - MPP_CHKSUM_ = mpp_chksum( mold, pelist, TRANSFER(mask_val, mold(1)) ) + MPP_CHKSUM_ = mpp_chksum( mold, pelist, TRANSFER(mask_val, mold(1)) ) else - MPP_CHKSUM_ = mpp_chksum( mold, pelist ) + MPP_CHKSUM_ = mpp_chksum( mold, pelist ) end if - return - end function MPP_CHKSUM_ + return +end function MPP_CHKSUM_ !> @} diff --git a/mpp/include/mpp_comm_mpi.inc b/mpp/include/mpp_comm_mpi.inc index 8345b23fa0..2ee1e88e3d 100644 --- a/mpp/include/mpp_comm_mpi.inc +++ b/mpp/include/mpp_comm_mpi.inc @@ -326,8 +326,6 @@ end subroutine mpp_exit integer, intent(in) :: from_pe !< pe to broadcast from integer, intent(in), optional :: pelist(:) !< optional pelist to broadcast to integer :: n, i, from_rank - character :: str1D(length*size(char_data(:))) - pointer(lptr, str1D) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'mpp_broadcast_text: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return @@ -352,7 +350,6 @@ end subroutine mpp_exit exit endif enddo - lptr = LOC (char_data) if( mpp_npes().GT.1 ) call MPI_BCAST( char_data, length*size(char_data(:)), & MPI_CHARACTER, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length ) diff --git a/mpp/include/mpp_data_mpi.inc b/mpp/include/mpp_data_mpi.inc index 43493cd24b..3a3fbff833 100644 --- a/mpp/include/mpp_data_mpi.inc +++ b/mpp/include/mpp_data_mpi.inc @@ -38,8 +38,8 @@ integer, parameter :: mpp_from_pe = -999, ptr_from = -999 !-------------------------------------------------------------------! ! The following data is used in mpp_domains_mod and its components ! !-------------------------------------------------------------------! -real(r8_kind), allocatable :: mpp_domains_stack(:) !< stack used to hold data for domain operations -real(r8_kind), allocatable :: mpp_domains_stack_nonblock(:) !< stack used for non-blocking domain operations +real(r8_kind), target, allocatable :: mpp_domains_stack(:) !< stack used to hold data for domain operations +real(r8_kind), target, allocatable :: mpp_domains_stack_nonblock(:) !< stack used for non-blocking domain operations !--- some dummy variables with dummy values that will never be used -integer, parameter :: ptr_domains_stack = -999 -integer, parameter :: ptr_domains_stack_nonblock = -999 +type(c_ptr), parameter :: ptr_domains_stakc = c_null_ptr +type(c_ptr), parameter :: ptr_domains_stakc_nonblock = c_null_ptr diff --git a/mpp/include/mpp_data_nocomm.inc b/mpp/include/mpp_data_nocomm.inc index f7de0670e4..f8d65de27a 100644 --- a/mpp/include/mpp_data_nocomm.inc +++ b/mpp/include/mpp_data_nocomm.inc @@ -38,8 +38,8 @@ integer, parameter :: mpp_from_pe = -999, ptr_from = -999 !-------------------------------------------------------------------! ! The following data is used in mpp_domains_mod and its components ! !-------------------------------------------------------------------! -real(r8_kind), allocatable :: mpp_domains_stack(:) -real(r8_kind), allocatable :: mpp_domains_stack_nonblock(:) +real(r8_kind), target, allocatable :: mpp_domains_stack(:) +real(r8_kind), target, allocatable :: mpp_domains_stack_nonblock(:) !--- some dummy variables with dummy values that will never be used -integer, parameter :: ptr_domains_stack = -999 -integer, parameter :: ptr_domains_stack_nonblock = -999 +type(c_ptr), parameter :: ptr_domains_stakc = c_null_ptr +type(c_ptr), parameter :: ptr_domains_stakc_nonblock = c_null_ptr diff --git a/mpp/include/mpp_do_check.fh b/mpp/include/mpp_do_check.fh index e724f924ff..fb8fddbbdf 100644 --- a/mpp/include/mpp_do_check.fh +++ b/mpp/include/mpp_do_check.fh @@ -24,7 +24,8 @@ !> Updates data domain of 3D field whose computational domains have been computed subroutine MPP_DO_CHECK_3D_( f_addrs, domain, check, d_type, ke, flags, name) - integer(i8_kind), intent(in) :: f_addrs(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: check MPP_TYPE_, intent(in) :: d_type ! tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -161,7 +164,8 @@ end do case(MINUS_NINETY) do l = 1, l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(check%xbegin:check%xend, check%ybegin:check%yend, 1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = is, ie @@ -174,7 +178,8 @@ end do case(NINETY) do l = 1, l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(check%xbegin:check%xend, check%ybegin:check%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = ie, is, -1 @@ -187,7 +192,8 @@ end do case(ONE_HUNDRED_EIGHTY) do l = 1, l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(check%xbegin:check%xend, check%ybegin:check%yend, 1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -225,7 +231,8 @@ buffer_pos = pos tMe = check%recv(m)%tileMe(n) do l=1, l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(check%xbegin:check%xend, check%ybegin:check%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie diff --git a/mpp/include/mpp_do_checkV.fh b/mpp/include/mpp_do_checkV.fh index 2c6df7a0df..b3863400a0 100644 --- a/mpp/include/mpp_do_checkV.fh +++ b/mpp/include/mpp_do_checkV.fh @@ -25,7 +25,8 @@ !> Updates data domain of 3D field whose computational domains have been computed subroutine MPP_DO_CHECK_3D_V_(f_addrsx,f_addrsy, domain, check_x, check_y, & d_type, ke, flags, name) - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: check_x, check_y integer, intent(in) :: ke @@ -33,18 +34,17 @@ integer, intent(in), optional :: flags character(len=*), intent(in), optional :: name - MPP_TYPE_ :: fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,ke) - MPP_TYPE_ :: fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,ke) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shapex(3), shapey(3) + integer, allocatable :: msg1(:), msg2(:) integer :: update_flags integer :: l_size, l, i, j, k, is, ie, js, je, n, m integer :: pos, nlist, msgsize integer :: to_pe, from_pe integer :: tMe - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer(ptr,buffer ) + MPP_TYPE_, pointer :: buffer(:) integer :: buffer_pos character(len=8) :: text character(len=64) :: field_name @@ -53,6 +53,8 @@ integer :: nsend_x, nsend_y, nrecv_x, nrecv_y integer :: outunit + shapex = [check_x%xend-check_x%xbegin+1, check_x%yend-check_x%ybegin+1, ke] + shapey = [check_y%xend-check_y%xbegin+1, check_y%yend-check_y%ybegin+1, ke] outunit = stdout() update_flags = XUPDATE+YUPDATE !default if( PRESENT(flags) ) update_flags = flags @@ -60,7 +62,7 @@ buffer_pos = 0 !this initialization goes away if update_domains becomes non-blocking l_size = size(f_addrsx,1) nlist = size(domain%list(:)) - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) !--- if debug_update_level is not NO_DEBUG, check the consistency on the bounds !--- (domain is symmetry or folded north edge). North bound will be checked when north edge is folded. @@ -241,8 +243,10 @@ select case( check_x%send(ind_x)%rotation(n) ) case(ZERO) do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -255,8 +259,10 @@ case(MINUS_NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = is, ie @@ -268,8 +274,10 @@ end do else do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = is, ie @@ -282,8 +290,10 @@ end if case(NINETY) do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = js, je do i = ie, is, -1 @@ -296,8 +306,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -309,8 +321,10 @@ end do else do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -341,8 +355,10 @@ select case( check_y%send(ind_y)%rotation(n) ) case(ZERO) do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -354,8 +370,10 @@ end do case(MINUS_NINETY) do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = is, ie @@ -368,8 +386,10 @@ case(NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = js, je do i = ie, is, -1 @@ -381,8 +401,10 @@ end do else do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = js, je do i = ie, is, -1 @@ -396,8 +418,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -409,8 +433,10 @@ end do else do l = 1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -461,8 +487,10 @@ buffer_pos = pos tMe = check_y%recv(ind_y)%tileMe(n) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -498,8 +526,10 @@ buffer_pos = pos tMe = check_x%recv(ind_x)%tileMe(n) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(check_x%xbegin:check_x%xend, check_x%ybegin:check_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(check_y%xbegin:check_y%xend, check_y%ybegin:check_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie diff --git a/mpp/include/mpp_do_get_boundary.fh b/mpp/include/mpp_do_get_boundary.fh index 5c391ac5b5..15a2cc3352 100644 --- a/mpp/include/mpp_do_get_boundary.fh +++ b/mpp/include/mpp_do_get_boundary.fh @@ -17,20 +17,18 @@ !* governing permissions and limitations under the License. !*********************************************************************** subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, d_type) + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated, c_f_pointer, c_loc type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: bound - integer(i8_kind), intent(in) :: f_addrs(:,:) - integer(i8_kind), intent(in) :: b_addrs(:,:,:) + type(c_ptr), intent(in) :: f_addrs(:,:) + type(c_ptr), intent(in) :: b_addrs(:,:,:) integer, intent(in) :: bsize(:), ke MPP_TYPE_, intent(in) :: d_type ! creates unique interface - MPP_TYPE_ :: field(bound%xbegin:bound%xend, bound%ybegin:bound%yend,ke) - MPP_TYPE_ :: ebuffer(bsize(1), ke), sbuffer(bsize(2), ke), wbuffer(bsize(3), ke), nbuffer(bsize(4), ke) - pointer(ptr_field, field) - pointer(ptr_ebuffer, ebuffer) - pointer(ptr_sbuffer, sbuffer) - pointer(ptr_wbuffer, wbuffer) - pointer(ptr_nbuffer, nbuffer) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_e(2), shape_s(2), shape_w(2), shape_n(2) integer, allocatable :: msg1(:), msg2(:) logical :: recv(4), send(4) @@ -40,16 +38,20 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, character(len=8) :: text integer :: outunit - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) + MPP_TYPE_, pointer :: buffer(:) - pointer( ptr, buffer ) - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) + shape_f = [bound%xend-bound%xbegin+1, bound%yend-bound%ybegin+1, ke] + shape_e = [bsize(1), ke] + shape_s = [bsize(2), ke] + shape_w = [bsize(3), ke] + shape_n = [bsize(4), ke] outunit = stdout() l_size = size(f_addrs,1) !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrs(1,:,1) == 0) + num = count_null_ptrs(b_addrs(1,:,1)) if( num == 0 ) then recv(1) = .true. else if( num == l_size ) then @@ -60,7 +62,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrs(2,:,1) == 0) + num = count_null_ptrs(b_addrs(2,:,1)) if( num == 0 ) then recv(2) = .true. else if( num == l_size ) then @@ -71,7 +73,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrs(3,:,1) == 0) + num = count_null_ptrs(b_addrs(3,:,1)) if( num == 0 ) then recv(3) = .true. else if( num == l_size ) then @@ -82,7 +84,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrs(4,:,1) == 0) + num = count_null_ptrs(b_addrs(4,:,1)) if( num == 0 ) then recv(4) = .true. else if( num == l_size ) then @@ -177,7 +179,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, select case( bound%send(m)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -189,7 +192,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case( MINUS_NINETY ) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -201,7 +205,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case( NINETY ) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -213,7 +218,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case (ONE_HUNDRED_EIGHTY) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -259,7 +265,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, select case( bound%recv(m)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebuffer = b_addrs(1, l, tMe) + call c_f_pointer(b_addrs(1, l, tMe), ebuffer, shape=shape_e) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -273,7 +279,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbuffer = b_addrs(2, l, tMe) + call c_f_pointer(b_addrs(2, l, tMe), sbuffer, shape=shape_s) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -287,7 +293,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbuffer = b_addrs(3, l, tMe) + call c_f_pointer(b_addrs(3, l, tMe), wbuffer, shape=shape_w) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -301,7 +307,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbuffer = b_addrs(4, l, tMe) + call c_f_pointer(b_addrs(4, l, tMe), nbuffer, shape=shape_n) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -320,35 +326,38 @@ subroutine MPP_DO_GET_BOUNDARY_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, call mpp_sync_self( ) +contains + integer function count_null_ptrs(ptrs) result(cnt) + type(c_ptr), intent(in) :: ptrs(:) + integer :: itr + cnt = 0 + do itr = 1, size(ptrs) + if (.not.c_associated(ptrs(itr))) cnt = cnt + 1 + end do + end function count_null_ptrs end subroutine MPP_DO_GET_BOUNDARY_3D_ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, b_addrsx, b_addrsy, & bsizex, bsizey, ke, d_type, flags, gridtype) + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated, c_f_pointer, c_loc type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: boundx, boundy - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) - integer(i8_kind), intent(in) :: b_addrsx(:,:,:), b_addrsy(:,:,:) + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + type(c_ptr), intent(in) :: b_addrsx(:,:,:), b_addrsy(:,:,:) integer, intent(in) :: bsizex(:), bsizey(:), ke MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: flags integer, intent(in) :: gridtype - MPP_TYPE_ :: fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend,ke) - MPP_TYPE_ :: fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend,ke) - MPP_TYPE_ :: ebufferx(bsizex(1), ke), sbufferx(bsizex(2), ke), wbufferx(bsizex(3), ke), nbufferx(bsizex(4), ke) - MPP_TYPE_ :: ebuffery(bsizey(1), ke), sbuffery(bsizey(2), ke), wbuffery(bsizey(3), ke), nbuffery(bsizey(4), ke) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) - pointer(ptr_ebufferx, ebufferx) - pointer(ptr_sbufferx, sbufferx) - pointer(ptr_wbufferx, wbufferx) - pointer(ptr_nbufferx, nbufferx) - pointer(ptr_ebuffery, ebuffery) - pointer(ptr_sbuffery, sbuffery) - pointer(ptr_wbuffery, wbuffery) - pointer(ptr_nbuffery, nbuffery) + MPP_TYPE_, pointer :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, pointer :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) + MPP_TYPE_, pointer :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_fx(3), shape_fy(3) + integer :: shape_ex(2), shape_sx(2), shape_wx(2), shape_nx(2) + integer :: shape_ey(2), shape_sy(2), shape_wy(2), shape_ny(2) integer, allocatable :: msg1(:), msg2(:) logical :: recvx(4), sendx(4) @@ -361,14 +370,24 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, character(len=8) :: text integer :: outunit, shift, midpoint - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer( ptr, buffer ) - ptr = LOC(mpp_domains_stack) + MPP_TYPE_, pointer :: buffer(:) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) + + shape_fx = [boundx%xend-boundx%xbegin+1, boundx%yend-boundx%ybegin+1, ke] + shape_fy = [boundy%xend-boundy%xbegin+1, boundy%yend-boundy%ybegin+1, ke] + shape_ex = [bsizex(1), ke] + shape_sx = [bsizex(2), ke] + shape_wx = [bsizex(3), ke] + shape_nx = [bsizex(4), ke] + shape_ey = [bsizey(1), ke] + shape_sy = [bsizey(2), ke] + shape_wy = [bsizey(3), ke] + shape_ny = [bsizey(4), ke] outunit = stdout() l_size = size(f_addrsx,1) !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrsx(1,:,1) == 0) + num = count_null_ptrs(b_addrsx(1,:,1)) if( num == 0 ) then recvx(1) = .true. else if( num == l_size ) then @@ -379,7 +398,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrsx(2,:,1) == 0) + num = count_null_ptrs(b_addrsx(2,:,1)) if( num == 0 ) then recvx(2) = .true. else if( num == l_size ) then @@ -390,7 +409,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrsx(3,:,1) == 0) + num = count_null_ptrs(b_addrsx(3,:,1)) if( num == 0 ) then recvx(3) = .true. else if( num == l_size ) then @@ -401,7 +420,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrsx(4,:,1) == 0) + num = count_null_ptrs(b_addrsx(4,:,1)) if( num == 0 ) then recvx(4) = .true. else if( num == l_size ) then @@ -412,7 +431,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrsy(1,:,1) == 0) + num = count_null_ptrs(b_addrsy(1,:,1)) if( num == 0 ) then recvy(1) = .true. else if( num == l_size ) then @@ -423,7 +442,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrsy(2,:,1) == 0) + num = count_null_ptrs(b_addrsy(2,:,1)) if( num == 0 ) then recvy(2) = .true. else if( num == l_size ) then @@ -434,7 +453,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrsy(3,:,1) == 0) + num = count_null_ptrs(b_addrsy(3,:,1)) if( num == 0 ) then recvy(3) = .true. else if( num == l_size ) then @@ -445,7 +464,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrsy(4,:,1) == 0) + num = count_null_ptrs(b_addrsy(4,:,1)) if( num == 0 ) then recvy(4) = .true. else if( num == l_size ) then @@ -643,7 +662,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, select case( boundx%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -656,7 +676,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, case( MINUS_NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -668,7 +689,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do else do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -681,7 +703,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end if case( NINETY ) do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -694,7 +717,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, case (ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -706,7 +730,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do else do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -739,7 +764,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, select case( boundy%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -751,7 +777,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case( MINUS_NINETY ) do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -764,7 +791,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, case( NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -776,7 +804,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do else do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -790,7 +819,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, case (ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -802,7 +832,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do else do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -860,7 +891,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, select case( boundy%recv(ind_y)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebuffery = b_addrsy(1, l, tMe) + call c_f_pointer(b_addrsy(1, l, tMe), ebuffery, shape=shape_ey) + do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -874,7 +906,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbuffery = b_addrsy(2, l, tMe) + call c_f_pointer(b_addrsy(2, l, tMe), sbuffery, shape=shape_sy) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -888,7 +920,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbuffery = b_addrsy(3, l, tMe) + call c_f_pointer(b_addrsy(3, l, tMe), wbuffery, shape=shape_wy) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -902,7 +934,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbuffery = b_addrsy(4, l, tMe) + call c_f_pointer(b_addrsy(4, l, tMe), nbuffery, shape=shape_ny) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -938,7 +970,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, select case( boundx%recv(ind_x)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebufferx = b_addrsx(1, l, tMe) + call c_f_pointer(b_addrsx(1, l, tMe), ebufferx, shape=shape_ex) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -952,7 +984,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbufferx = b_addrsx(2, l, tMe) + call c_f_pointer(b_addrsx(2, l, tMe), sbufferx, shape=shape_sx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -966,7 +998,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbufferx = b_addrsx(3, l, tMe) + call c_f_pointer(b_addrsx(3, l, tMe), wbufferx, shape=shape_wx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -980,7 +1012,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbufferx = b_addrsx(4, l, tMe) + call c_f_pointer(b_addrsx(4, l, tMe), nbufferx, shape=shape_nx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -1020,8 +1052,8 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, do i = is ,ie, midpoint if( domain%x(1)%compute%begin == i )then do l=1,l_size - ptr_wbufferx = b_addrsx(3, l, tMe) - ptr_wbuffery = b_addrsy(3, l, tMe) + call c_f_pointer(b_addrsx(3, l, tMe), wbufferx, shape=shape_wx) + call c_f_pointer(b_addrsy(3, l, tMe), wbuffery, shape=shape_wy) do k = 1,ke wbufferx(j,k) = 0 wbuffery(j,k) = 0 @@ -1035,6 +1067,14 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, call mpp_sync_self( ) - +contains + integer function count_null_ptrs(ptrs) result(cnt) + type(c_ptr), intent(in) :: ptrs(:) + integer :: itr + cnt = 0 + do itr = 1, size(ptrs) + if (.not.c_associated(ptrs(itr))) cnt = cnt + 1 + end do + end function count_null_ptrs end subroutine MPP_DO_GET_BOUNDARY_3D_V_ diff --git a/mpp/include/mpp_do_get_boundary_ad.fh b/mpp/include/mpp_do_get_boundary_ad.fh index 2787ec4955..dc6236eb63 100644 --- a/mpp/include/mpp_do_get_boundary_ad.fh +++ b/mpp/include/mpp_do_get_boundary_ad.fh @@ -19,20 +19,18 @@ !*********************************************************************** subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, d_type) + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated, c_f_pointer, c_loc type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: bound - integer(i8_kind), intent(in) :: f_addrs(:,:) - integer(i8_kind), intent(in) :: b_addrs(:,:,:) + type(c_ptr), intent(in) :: f_addrs(:,:) + type(c_ptr), intent(in) :: b_addrs(:,:,:) integer, intent(in) :: bsize(:), ke MPP_TYPE_, intent(in) :: d_type ! creates unique interface - MPP_TYPE_ :: field(bound%xbegin:bound%xend, bound%ybegin:bound%yend,ke) - MPP_TYPE_ :: ebuffer(bsize(1), ke), sbuffer(bsize(2), ke), wbuffer(bsize(3), ke), nbuffer(bsize(4), ke) - pointer(ptr_field, field) - pointer(ptr_ebuffer, ebuffer) - pointer(ptr_sbuffer, sbuffer) - pointer(ptr_wbuffer, wbuffer) - pointer(ptr_nbuffer, nbuffer) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_e(2), shape_s(2), shape_w(2), shape_n(2) integer, allocatable :: msg1(:), msg2(:) logical :: recv(4), send(4) @@ -42,16 +40,20 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k character(len=8) :: text integer :: outunit - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) + MPP_TYPE_, pointer :: buffer(:) - pointer( ptr, buffer ) - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) + shape_f = [bound%xend-bound%xbegin+1, bound%yend-bound%ybegin+1, ke] + shape_e = [bsize(1), ke] + shape_s = [bsize(2), ke] + shape_w = [bsize(3), ke] + shape_n = [bsize(4), ke] outunit = stdout() l_size = size(f_addrs,1) !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrs(1,:,1) == 0) + num = count_null_ptrs(b_addrs(1,:,1)) if( num == 0 ) then recv(1) = .true. else if( num == l_size ) then @@ -62,7 +64,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrs(2,:,1) == 0) + num = count_null_ptrs(b_addrs(2,:,1)) if( num == 0 ) then recv(2) = .true. else if( num == l_size ) then @@ -73,7 +75,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrs(3,:,1) == 0) + num = count_null_ptrs(b_addrs(3,:,1)) if( num == 0 ) then recv(3) = .true. else if( num == l_size ) then @@ -84,7 +86,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrs(4,:,1) == 0) + num = count_null_ptrs(b_addrs(4,:,1)) if( num == 0 ) then recv(4) = .true. else if( num == l_size ) then @@ -179,7 +181,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k select case( bound%send(m)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -191,7 +194,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case( MINUS_NINETY ) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -203,7 +207,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case( NINETY ) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -215,7 +220,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case (ONE_HUNDRED_EIGHTY) do l=1,l_size - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape_f) + field(bound%xbegin:bound%xend, bound%ybegin:bound%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -261,7 +267,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k select case( bound%recv(m)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebuffer = b_addrs(1, l, tMe) + call c_f_pointer(b_addrs(1, l, tMe), ebuffer, shape=shape_e) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -275,7 +281,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbuffer = b_addrs(2, l, tMe) + call c_f_pointer(b_addrs(2, l, tMe), sbuffer, shape=shape_s) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -289,7 +295,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbuffer = b_addrs(3, l, tMe) + call c_f_pointer(b_addrs(3, l, tMe), wbuffer, shape=shape_w) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -303,7 +309,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbuffer = b_addrs(4, l, tMe) + call c_f_pointer(b_addrs(4, l, tMe), nbuffer, shape=shape_n) do k = 1, ke index = bound%recv(m)%index(n) do j = js, je @@ -322,35 +328,38 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, k call mpp_sync_self( ) +contains + integer function count_null_ptrs(ptrs) result(cnt) + type(c_ptr), intent(in) :: ptrs(:) + integer :: itr + cnt = 0 + do itr = 1, size(ptrs) + if (.not.c_associated(ptrs(itr))) cnt = cnt + 1 + end do + end function count_null_ptrs end subroutine MPP_DO_GET_BOUNDARY_AD_3D_ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, b_addrsx, b_addrsy, & bsizex, bsizey, ke, d_type, flags, gridtype) + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated, c_f_pointer, c_loc type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: boundx, boundy - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) - integer(i8_kind), intent(in) :: b_addrsx(:,:,:), b_addrsy(:,:,:) + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + type(c_ptr), intent(in) :: b_addrsx(:,:,:), b_addrsy(:,:,:) integer, intent(in) :: bsizex(:), bsizey(:), ke MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: flags integer, intent(in) :: gridtype - MPP_TYPE_ :: fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend,ke) - MPP_TYPE_ :: fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend,ke) - MPP_TYPE_ :: ebufferx(bsizex(1), ke), sbufferx(bsizex(2), ke), wbufferx(bsizex(3), ke), nbufferx(bsizex(4), ke) - MPP_TYPE_ :: ebuffery(bsizey(1), ke), sbuffery(bsizey(2), ke), wbuffery(bsizey(3), ke), nbuffery(bsizey(4), ke) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) - pointer(ptr_ebufferx, ebufferx) - pointer(ptr_sbufferx, sbufferx) - pointer(ptr_wbufferx, wbufferx) - pointer(ptr_nbufferx, nbufferx) - pointer(ptr_ebuffery, ebuffery) - pointer(ptr_sbuffery, sbuffery) - pointer(ptr_wbuffery, wbuffery) - pointer(ptr_nbuffery, nbuffery) + MPP_TYPE_, pointer :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, pointer :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) + MPP_TYPE_, pointer :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_fx(3), shape_fy(3) + integer :: shape_ex(2), shape_sx(2), shape_wx(2), shape_nx(2) + integer :: shape_ey(2), shape_sy(2), shape_wy(2), shape_ny(2) integer, allocatable :: msg1(:), msg2(:) logical :: recvx(4), sendx(4) @@ -363,14 +372,24 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun character(len=8) :: text integer :: outunit, shift, midpoint - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer( ptr, buffer ) - ptr = LOC(mpp_domains_stack) + MPP_TYPE_, pointer :: buffer(:) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) + + shape_fx = [boundx%xend-boundx%xbegin+1, boundx%yend-boundx%ybegin+1, ke] + shape_fy = [boundy%xend-boundy%xbegin+1, boundy%yend-boundy%ybegin+1, ke] + shape_ex = [bsizex(1), ke] + shape_sx = [bsizex(2), ke] + shape_wx = [bsizex(3), ke] + shape_nx = [bsizex(4), ke] + shape_ey = [bsizey(1), ke] + shape_sy = [bsizey(2), ke] + shape_wy = [bsizey(3), ke] + shape_ny = [bsizey(4), ke] outunit = stdout() l_size = size(f_addrsx,1) !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrsx(1,:,1) == 0) + num = count_null_ptrs(b_addrsx(1,:,1)) if( num == 0 ) then recvx(1) = .true. else if( num == l_size ) then @@ -381,7 +400,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrsx(2,:,1) == 0) + num = count_null_ptrs(b_addrsx(2,:,1)) if( num == 0 ) then recvx(2) = .true. else if( num == l_size ) then @@ -392,7 +411,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrsx(3,:,1) == 0) + num = count_null_ptrs(b_addrsx(3,:,1)) if( num == 0 ) then recvx(3) = .true. else if( num == l_size ) then @@ -403,7 +422,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrsx(4,:,1) == 0) + num = count_null_ptrs(b_addrsx(4,:,1)) if( num == 0 ) then recvx(4) = .true. else if( num == l_size ) then @@ -414,7 +433,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(1) based on b_addrs ( east boundary ) - num = count(b_addrsy(1,:,1) == 0) + num = count_null_ptrs(b_addrsy(1,:,1)) if( num == 0 ) then recvy(1) = .true. else if( num == l_size ) then @@ -425,7 +444,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(2) based on b_addrs ( south boundary ) - num = count(b_addrsy(2,:,1) == 0) + num = count_null_ptrs(b_addrsy(2,:,1)) if( num == 0 ) then recvy(2) = .true. else if( num == l_size ) then @@ -436,7 +455,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(3) based on b_addrs ( west boundary ) - num = count(b_addrsy(3,:,1) == 0) + num = count_null_ptrs(b_addrsy(3,:,1)) if( num == 0 ) then recvy(3) = .true. else if( num == l_size ) then @@ -447,7 +466,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun endif !---- determine recv(4) based on b_addrs ( north boundary ) - num = count(b_addrsy(4,:,1) == 0) + num = count_null_ptrs(b_addrsy(4,:,1)) if( num == 0 ) then recvy(4) = .true. else if( num == l_size ) then @@ -588,8 +607,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun do i = is ,ie, midpoint if( domain%x(1)%compute%begin == i )then do l=1,l_size - ptr_wbufferx = b_addrsx(3, l, tMe) - ptr_wbuffery = b_addrsy(3, l, tMe) + call c_f_pointer(b_addrsx(3, l, tMe), wbufferx, shape=shape_wx) + call c_f_pointer(b_addrsy(3, l, tMe), wbuffery, shape=shape_wy) do k = 1,ke wbufferx(j,k) = 0 wbuffery(j,k) = 0 @@ -667,7 +686,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun select case( boundy%recv(ind_y)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebuffery = b_addrsy(1, l, tMe) + call c_f_pointer(b_addrsy(1, l, tMe), ebuffery, shape=shape_ey) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -682,7 +701,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbuffery = b_addrsy(2, l, tMe) + call c_f_pointer(b_addrsy(2, l, tMe), sbuffery, shape=shape_sy) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -697,7 +716,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbuffery = b_addrsy(3, l, tMe) + call c_f_pointer(b_addrsy(3, l, tMe), wbuffery, shape=shape_wy) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -712,7 +731,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbuffery = b_addrsy(4, l, tMe) + call c_f_pointer(b_addrsy(4, l, tMe), nbuffery, shape=shape_ny) do k = 1, ke index = boundy%recv(ind_y)%index(n) do j = js, je @@ -749,7 +768,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun select case( boundx%recv(ind_x)%dir(n) ) case ( 1 ) ! EAST do l=1,l_size - ptr_ebufferx = b_addrsx(1, l, tMe) + call c_f_pointer(b_addrsx(1, l, tMe), ebufferx, shape=shape_ex) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -764,7 +783,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 2 ) ! SOUTH do l=1,l_size - ptr_sbufferx = b_addrsx(2, l, tMe) + call c_f_pointer(b_addrsx(2, l, tMe), sbufferx, shape=shape_sx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -779,7 +798,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 3 ) ! WEST do l=1,l_size - ptr_wbufferx = b_addrsx(3, l, tMe) + call c_f_pointer(b_addrsx(3, l, tMe), wbufferx, shape=shape_wx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -794,7 +813,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case ( 4 ) ! norTH do l=1,l_size - ptr_nbufferx = b_addrsx(4, l, tMe) + call c_f_pointer(b_addrsx(4, l, tMe), nbufferx, shape=shape_nx) do k = 1, ke index = boundx%recv(ind_x)%index(n) do j = js, je @@ -952,7 +971,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun select case( boundx%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -965,7 +985,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun case( MINUS_NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -977,7 +998,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do else do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -990,7 +1012,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end if case( NINETY ) do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -1003,7 +1026,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun case (ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -1015,7 +1039,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do else do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -1048,7 +1073,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun select case( boundy%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = is, ie @@ -1060,7 +1086,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do case( MINUS_NINETY ) do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = is, ie @@ -1073,7 +1100,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun case( NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -1085,7 +1113,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do else do l=1,l_size - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l, tMe), tmpptr, shape=shape_fx) + fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend, 1:ke) => tmpptr do k = 1, ke do j = js, je do i = ie, is, -1 @@ -1099,7 +1128,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun case (ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -1111,7 +1141,8 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun end do else do l=1,l_size - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsy(l, tMe), tmpptr, shape=shape_fy) + fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend, 1:ke) => tmpptr do k = 1, ke do j = je, js, -1 do i = ie, is, -1 @@ -1144,5 +1175,14 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun call mpp_sync_self( ) +contains + integer function count_null_ptrs(ptrs) result(cnt) + type(c_ptr), intent(in) :: ptrs(:) + integer :: itr + cnt = 0 + do itr = 1, size(ptrs) + if (.not.c_associated(ptrs(itr))) cnt = cnt + 1 + end do + end function count_null_ptrs end subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_ diff --git a/mpp/include/mpp_do_global_field.fh b/mpp/include/mpp_do_global_field.fh index 1a665e1a50..7d557d8d4d 100644 --- a/mpp/include/mpp_do_global_field.fh +++ b/mpp/include/mpp_do_global_field.fh @@ -21,6 +21,7 @@ !> Gets a global field from a local field !! local field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_( domain, local, global, tile, ishift, jshift, flags, default_data) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(domain2D), intent(in) :: domain MPP_TYPE_, intent(in) :: local(:,:,:) integer, intent(in) :: tile, ishift, jshift @@ -32,14 +33,12 @@ integer :: ke, isc, iec, jsc, jec, is, ie, js, je, num_word_me integer :: ipos, jpos logical :: xonly, yonly, root_only, global_on_this_pe - MPP_TYPE_ :: clocal ((domain%x(1)%compute%size+ishift) *(domain%y(1)%compute%size+jshift) *size(local,3)) - MPP_TYPE_ :: cremote((domain%x(1)%compute%max_size+ishift)*(domain%y(1)%compute%max_size+jshift)*size(local,3)) + MPP_TYPE_, pointer :: clocal (:) + MPP_TYPE_, pointer :: cremote(:) + integer :: local_stack_size, remote_stack_size integer :: stackuse character(len=8) :: text - pointer( ptr_local, clocal ) - pointer( ptr_remote, cremote ) - stackuse = size(clocal(:))+size(cremote(:)) if( stackuse.GT.mpp_domains_stack_size )then write( text, '(i8)' )stackuse @@ -49,8 +48,10 @@ end if mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse ) - ptr_local = LOC(mpp_domains_stack) - ptr_remote = LOC(mpp_domains_stack(size(clocal(:))+1)) + local_stack_size = (domain%x(1)%compute%size+ishift) *(domain%y(1)%compute%size+jshift) *size(local,3) + remote_stack_size = (domain%x(1)%compute%max_size+ishift)*(domain%y(1)%compute%max_size+jshift)*size(local,3) + call c_f_pointer(c_loc(mpp_domains_stack(1)), clocal, [local_stack_size ]) + call c_f_pointer(c_loc(mpp_domains_stack(local_stack_size+1)), cremote, [remote_stack_size]) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' ) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index 8fa726a26f..d99e772def 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -24,6 +24,7 @@ !> Gets a local ad field from a global field !! global field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_AD_( domain, local, global, tile, ishift, jshift, flags, default_data) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(domain2D), intent(in) :: domain MPP_TYPE_, intent(inout) :: local(:,:,:) integer, intent(in) :: tile, ishift, jshift @@ -34,14 +35,12 @@ integer :: ke, isc, iec, jsc, jec, is, ie, js, je, num_word_me integer :: ipos, jpos logical :: xonly, yonly, root_only, global_on_this_pe - MPP_TYPE_ :: clocal ((domain%x(1)%compute%size+ishift) *(domain%y(1)%compute%size+jshift) *size(local,3)) - MPP_TYPE_ :: cremote((domain%x(1)%compute%max_size+ishift)*(domain%y(1)%compute%max_size+jshift)*size(local,3)) + MPP_TYPE_, pointer :: clocal (:) + MPP_TYPE_, pointer :: cremote(:) + integer :: local_stack_size, remote_stack_size integer :: stackuse character(len=8) :: text - pointer( ptr_local, clocal ) - pointer( ptr_remote, cremote ) - stackuse = size(clocal(:))+size(cremote(:)) if( stackuse.GT.mpp_domains_stack_size )then write( text, '(i8)' )stackuse @@ -51,8 +50,10 @@ end if mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse ) - ptr_local = LOC(mpp_domains_stack) - ptr_remote = LOC(mpp_domains_stack(size(clocal(:))+1)) + local_stack_size = (domain%x(1)%compute%size+ishift) *(domain%y(1)%compute%size+jshift) *size(local,3) + remote_stack_size = (domain%x(1)%compute%max_size+ishift)*(domain%y(1)%compute%max_size+jshift)*size(local,3) + call c_f_pointer(c_loc(mpp_domains_stack(1)), clocal, [local_stack_size ]) + call c_f_pointer(c_loc(mpp_domains_stack(local_stack_size+1)), cremote, [remote_stack_size]) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' ) diff --git a/mpp/include/mpp_do_redistribute.fh b/mpp/include/mpp_do_redistribute.fh index 5acf4bb314..85ae9eb355 100644 --- a/mpp/include/mpp_do_redistribute.fh +++ b/mpp/include/mpp_do_redistribute.fh @@ -18,34 +18,35 @@ !> @addtogroup mpp_domains_mod !> @{ subroutine MPP_DO_REDISTRIBUTE_3D_( f_in, f_out, d_comm, d_type ) - integer(i8_kind), intent(in) :: f_in(:), f_out(:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) :: d_comm MPP_TYPE_, intent(in) :: d_type - MPP_TYPE_ :: field_in(d_comm%domain_in%x(1)%domain_data%begin:d_comm%domain_in%x(1)%domain_data%end, & - d_comm%domain_in%y(1)%domain_data%begin:d_comm%domain_in%y(1)%domain_data%end,d_comm%ke) - pointer( ptr_field_in, field_in) - MPP_TYPE_ :: field_out(d_comm%domain_out%x(1)%domain_data%begin:d_comm%domain_out%x(1)%domain_data%end, & - d_comm%domain_out%y(1)%domain_data%begin:d_comm%domain_out%y(1)%domain_data%end,d_comm%ke) - pointer( ptr_field_out, field_out) + MPP_TYPE_, pointer :: field_in(:,:,:) + MPP_TYPE_, pointer :: field_out(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_in(3), shape_out(3) type(domain2D), pointer :: domain_in, domain_out integer :: i, j, k, l, n, l_size integer :: is, ie, js, je integer :: ke integer :: list, pos, msgsize integer :: to_pe, from_pe - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer( ptr, buffer ) - integer :: buffer_pos, wordlen, errunit + MPP_TYPE_, pointer :: buffer(:) + integer :: buffer_pos, errunit !fix ke + shape_in = [d_comm%domain_in%x(1)%domain_data%end-d_comm%domain_in%x(1)%domain_data%begin+1, & + d_comm%domain_in%y(1)%domain_data%end-d_comm%domain_in%y(1)%domain_data%begin+1, d_comm%ke] + shape_out = [d_comm%domain_out%x(1)%domain_data%end-d_comm%domain_out%x(1)%domain_data%begin+1, & + d_comm%domain_out%y(1)%domain_data%end-d_comm%domain_out%y(1)%domain_data%begin+1, d_comm%ke] errunit = stderr() l_size = size(f_out(:)) ! equal to size(f_in(:)) ke = d_comm%ke domain_in =>d_comm%domain_in; domain_out =>d_comm%domain_out buffer_pos = 0 - ptr = LOC(mpp_domains_stack) - wordlen = size(TRANSFER(buffer(1),mpp_domains_stack)) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) !pre-post recv n = d_comm%Rlist_size @@ -66,7 +67,9 @@ js=d_comm%sendjs(1,list); je=d_comm%sendje(1,list) pos = buffer_pos do l=1,l_size ! loop over number of fields - ptr_field_in = f_in(l) + call c_f_pointer(f_in(l), tmpptr, shape=shape_in) + field_in(d_comm%domain_in%x(1)%domain_data%begin:d_comm%domain_in%x(1)%domain_data%end, & + d_comm%domain_in%y(1)%domain_data%begin:d_comm%domain_in%y(1)%domain_data%end, 1:d_comm%ke) => tmpptr do k = 1,ke do j = js,je do i = is,ie @@ -95,7 +98,9 @@ if( debug )write( errunit,* )'PE', pe, ' from PE ', from_pe, 'is,ie,js,je=', is, ie, js, je pos = buffer_pos do l=1,l_size ! loop over number of in/out fields - ptr_field_out = f_out(l) + call c_f_pointer(f_out(l), tmpptr, shape=shape_out) + field_out(d_comm%domain_out%x(1)%domain_data%begin:d_comm%domain_out%x(1)%domain_data%end, & + d_comm%domain_out%y(1)%domain_data%begin:d_comm%domain_out%y(1)%domain_data%end, 1:d_comm%ke) => tmpptr do k = 1,ke do j = js,je do i = is,ie diff --git a/mpp/include/mpp_do_update.fh b/mpp/include/mpp_do_update.fh index 0fa38a8a76..a8ff3ddea2 100644 --- a/mpp/include/mpp_do_update.fh +++ b/mpp/include/mpp_do_update.fh @@ -20,22 +20,23 @@ !> @{ !> Updates data domain of 3D field whose computational domains have been computed subroutine MPP_DO_UPDATE_3D_( f_addrs, domain, update, d_type, ke, flags) - integer(i8_kind), intent(in) :: f_addrs(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: update MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: ke integer, optional, intent(in) :: flags - MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke) - pointer(ptr_field, field) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape(3) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() character(len=8) :: text !equate to mpp_domains_stack - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer( ptr, buffer ) + MPP_TYPE_, pointer :: buffer(:) integer :: buffer_pos !receive domains saved here for unpacking @@ -50,8 +51,9 @@ integer :: send_msgsize(MAXLIST) + shape = [update%xend-update%xbegin+1, update%yend-update%ybegin+1, ke] outunit = stdout() - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) l_size = size(f_addrs,1) update_flags = XUPDATE+YUPDATE !default @@ -192,7 +194,8 @@ select case( overPtr%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -204,7 +207,8 @@ end do case( MINUS_NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -216,7 +220,8 @@ end do case( NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -228,7 +233,8 @@ end do case( ONE_HUNDRED_EIGHTY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -259,7 +265,7 @@ !unpack recv !unpack halos in reverse order -! ptr_rfield = f_addrs(1) +! type(c_ptr) :: ptr_rfield = f_addrs(1) call mpp_clock_begin(wait_clock) call mpp_sync_self(check=EVENT_RECV) call mpp_clock_end(wait_clock) @@ -280,7 +286,8 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie diff --git a/mpp/include/mpp_do_updateV.fh b/mpp/include/mpp_do_updateV.fh index 378a2a6211..9d185d5681 100644 --- a/mpp/include/mpp_do_updateV.fh +++ b/mpp/include/mpp_do_updateV.fh @@ -21,7 +21,8 @@ !> Updates data domain of 3D field whose computational domains have been computed subroutine MPP_DO_UPDATE_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: update_x, update_y integer, intent(in) :: ke @@ -29,10 +30,9 @@ integer, intent(in) :: gridtype integer, intent(in), optional :: flags - MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke) - MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shapex(3), shapey(3) !< shapes of fieldx and fieldy integer :: update_flags integer :: l_size, l, i, j, k, is, ie, js, je, n, m @@ -45,14 +45,16 @@ integer :: send_pe(2*MAXLIST) integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer(ptr,buffer ) + MPP_TYPE_, pointer :: buffer(:) integer :: buffer_pos character(len=8) :: text integer :: buffer_recv_size, shift integer :: rank_x, rank_y, ind_x, ind_y, cur_rank integer :: nsend_x, nsend_y, nrecv_x, nrecv_y, outunit + + shapex = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke] + shapey = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke] outunit = stdout() update_flags = XUPDATE+YUPDATE !default if( PRESENT(flags) ) then @@ -93,7 +95,7 @@ l_size = size(f_addrsx,1) nlist = size(domain%list(:)) - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) !recv nsend_x = update_x%nsend @@ -340,8 +342,10 @@ select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -355,8 +359,10 @@ case( MINUS_NINETY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -369,8 +375,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -385,8 +393,10 @@ case( NINETY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -399,8 +409,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -415,8 +427,10 @@ case( ONE_HUNDRED_EIGHTY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -429,8 +443,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -467,8 +483,10 @@ select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -481,8 +499,10 @@ case(MINUS_NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -494,8 +514,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -508,8 +530,10 @@ end if case(NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1, ke do i = ie, is, -1 do j = js, je @@ -522,8 +546,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -535,8 +561,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -569,8 +597,10 @@ select case( update_y%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -582,8 +612,10 @@ end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -596,8 +628,10 @@ case(NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -609,8 +643,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -624,8 +660,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -637,8 +675,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -704,8 +744,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -740,8 +782,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -772,8 +816,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -818,8 +864,10 @@ do i = is ,ie, midpoint if( isd.LE.i .AND. i.LE. ied+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -845,8 +893,10 @@ if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = isd,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) @@ -861,7 +911,8 @@ if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = isd,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -882,8 +933,10 @@ is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -893,7 +946,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -917,8 +971,10 @@ do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -941,8 +997,10 @@ if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) @@ -957,7 +1015,8 @@ if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -978,8 +1037,10 @@ is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -989,7 +1050,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -1013,8 +1075,10 @@ do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -1037,8 +1101,10 @@ if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) @@ -1053,7 +1119,8 @@ if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) @@ -1074,8 +1141,10 @@ js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -1085,7 +1154,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr do k = 1,ke do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) @@ -1109,8 +1179,10 @@ do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -1133,8 +1205,10 @@ if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) @@ -1149,7 +1223,8 @@ if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) @@ -1170,8 +1245,10 @@ js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -1181,7 +1258,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr do k = 1,ke do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index a8a2f54e88..dba2a48bdc 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -23,7 +23,8 @@ !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: update_x, update_y integer, intent(in) :: ke @@ -31,10 +32,11 @@ integer, intent(in) :: gridtype integer, intent(in), optional :: flags - MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke) - MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + !MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke) + !MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke) + MPP_TYPE_, pointer :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shapex(3), shapey(3) integer :: update_flags integer :: l_size, l, i, j, k, is, ie, js, je, n, m @@ -44,13 +46,14 @@ integer, allocatable :: msg1(:), msg2(:) logical :: send(8), recv(8), update_edge_only - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer(ptr,buffer ) + MPP_TYPE_, pointer :: buffer(:) integer :: buffer_pos integer :: buffer_recv_size, shift integer :: rank_x, rank_y, ind_x, ind_y, cur_rank integer :: nsend_x, nsend_y, nrecv_x, nrecv_y, outunit + shapex = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke] + shapey = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke] outunit = stdout() update_flags = XUPDATE+YUPDATE !default if( PRESENT(flags) ) then @@ -90,7 +93,7 @@ l_size = size(f_addrsx,1) nlist = size(domain%list(:)) - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) !recv nsend_x = update_x%nsend @@ -300,8 +303,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -338,8 +343,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -371,8 +378,10 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -413,8 +422,10 @@ do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -441,8 +452,10 @@ if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) @@ -457,7 +470,10 @@ if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) @@ -478,8 +494,10 @@ is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -489,7 +507,10 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -513,8 +534,10 @@ do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -537,8 +560,10 @@ if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) @@ -553,7 +578,10 @@ if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) @@ -574,8 +602,10 @@ is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -585,7 +615,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -609,8 +640,10 @@ do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -633,8 +666,10 @@ if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) @@ -649,7 +684,8 @@ if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) @@ -670,8 +706,10 @@ js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -681,7 +719,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) @@ -705,8 +744,10 @@ do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -729,8 +770,10 @@ if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) @@ -745,7 +788,8 @@ if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) @@ -766,8 +810,10 @@ js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -777,7 +823,8 @@ end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) @@ -963,8 +1010,10 @@ select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr(:,:,:) do k = 1,ke do j = js, je do i = is, ie @@ -978,8 +1027,10 @@ case( MINUS_NINETY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -992,8 +1043,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1008,8 +1061,10 @@ case( NINETY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1022,8 +1077,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1038,8 +1095,10 @@ case( ONE_HUNDRED_EIGHTY ) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -1052,8 +1111,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -1090,8 +1151,10 @@ select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -1104,8 +1167,10 @@ case(MINUS_NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1117,8 +1182,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1131,8 +1198,10 @@ end if case(NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1, ke do i = ie, is, -1 do j = js, je @@ -1145,8 +1214,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -1158,8 +1229,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -1193,8 +1266,10 @@ select case( update_y%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -1206,8 +1281,10 @@ end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1220,8 +1297,10 @@ case(NINETY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1233,8 +1312,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1248,8 +1329,10 @@ case(ONE_HUNDRED_EIGHTY) if( BTEST(update_flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 @@ -1261,8 +1344,10 @@ end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 diff --git a/mpp/include/mpp_do_updateV_nonblock.fh b/mpp/include/mpp_do_updateV_nonblock.fh index 321e993c4c..5b974dcf12 100644 --- a/mpp/include/mpp_do_updateV_nonblock.fh +++ b/mpp/include/mpp_do_updateV_nonblock.fh @@ -20,8 +20,9 @@ !> @{ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, update_x, update_y, & d_type, ke_max, ke_list, gridtype, flags, reuse_id_update, name) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc integer, intent(in) :: id_update - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: update_x, update_y integer, intent(in) :: ke_max @@ -47,14 +48,14 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda integer :: ind_recv_x(update_x%nrecv+update_y%nrecv), ind_recv_y(update_x%nrecv+update_y%nrecv) integer :: from_pe_list(update_x%nrecv+update_y%nrecv), to_pe_list(update_x%nsend+update_y%nsend) integer :: start_pos_recv(update_x%nrecv+update_y%nrecv), start_pos_send(update_x%nsend+update_y%nsend) - MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke_max) - MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke_max) - MPP_TYPE_ :: buffer(size(mpp_domains_stack_nonblock(:))) - - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) - pointer( ptr, buffer ) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + MPP_TYPE_, pointer :: buffer(:) + integer :: shapex(3), shapey(3) + shapex = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke_max] + shapey = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke_max] update_edge_only = BTEST(flags, EDGEONLY) recv = .false. recv(1) = BTEST(flags,EAST) @@ -80,7 +81,7 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda ke_sum = sum(ke_list) l_size = size(f_addrsx,1) nlist = size(domain%list(:)) - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), buffer, [size(mpp_domains_stack_nonblock)]) nrecv = get_vector_recv(domain, update_x, update_y, ind_recv_x, ind_recv_y, start_pos_recv, from_pe_list) nsend = get_vector_send(domain, update_x, update_y, ind_send_x, ind_send_y, start_pos_send, to_pe_list) @@ -199,7 +200,7 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda call mpp_clock_begin(send_pack_clock_nonblock) !$OMP parallel do schedule(dynamic) default(shared) private(ind_x,ind_y,buffer_pos,pos,dir,tMe, & -!$OMP is,ie,js,je,ptr_fieldx,ptr_fieldy) +!$OMP is,ie,js,je,tmpptr,fieldx,fieldy) do m = 1, nsend send_msgsize(m) = 0 ind_x = ind_send_x(m) @@ -219,8 +220,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -234,8 +237,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case( MINUS_NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -248,8 +253,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -264,8 +271,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case( NINETY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = ie, is, -1 do j = js, je @@ -278,8 +287,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = ie, is, -1 do j = js, je @@ -294,8 +305,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case( ONE_HUNDRED_EIGHTY ) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -308,8 +321,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -336,8 +351,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda select case( update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -350,8 +367,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case(MINUS_NINETY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -363,8 +382,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -377,8 +398,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end if case(NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1, ke_list(l,tMe) do i = ie, is, -1 do j = js, je @@ -391,8 +414,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case(ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -404,8 +429,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -430,8 +457,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda select case( update_y%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -443,8 +472,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -457,8 +488,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case(NINETY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = ie, is, -1 do j = js, je @@ -470,8 +503,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = ie, is, -1 do j = js, je @@ -485,8 +520,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda case(ONE_HUNDRED_EIGHTY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -498,8 +535,10 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l,tMe) - ptr_fieldy = f_addrsy(l,tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -537,8 +576,9 @@ end subroutine MPP_START_DO_UPDATE_3D_V_ !############################################################################### subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, update_x, update_y, & d_type, ke_max, ke_list, gridtype, flags) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc integer, intent(in) :: id_update - integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) + type(c_ptr), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: update_x, update_y integer, intent(in) :: ke_max @@ -549,13 +589,12 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !--- local variables - MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke_max) - MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke_max) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shapex(3), shapey(3) - MPP_TYPE_ :: recv_buffer(size(mpp_domains_stack_nonblock(:))) - pointer( ptr, recv_buffer ) + MPP_TYPE_, pointer :: recv_buffer(:) integer :: i, j, k, l, is, ie, js, je, n, ke_sum, l_size, m integer :: pos, nlist, msgsize, buffer_pos @@ -567,6 +606,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u integer :: shift, midpoint integer :: tMe, dir + shapex = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke_max] + shapey = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke_max] update_edge_only = BTEST(flags, EDGEONLY) recv = .false. recv(1) = BTEST(flags,EAST) @@ -592,7 +633,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u ke_sum = sum(ke_list) l_size = size(f_addrsx,1) nlist = size(domain%list(:)) - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), recv_buffer, [size(mpp_domains_stack_nonblock)]) nrecv = get_vector_recv(domain, update_x, update_y, ind_recv_x, ind_recv_y, start_pos_recv, from_pe_list) @@ -612,7 +653,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_clock_begin(unpk_clock_nonblock) !$OMP parallel do schedule(dynamic) default(shared) private(ind_x,ind_y,buffer_pos,pos,dir,tMe,is,ie,js,je, & -!$OMP msgsize,ptr_fieldx,ptr_fieldy) +!$OMP msgsize,tmpptr,fieldx,fieldy) do m = nrecv,1,-1 ind_x = ind_recv_x(m) ind_y = ind_recv_y(m) @@ -631,8 +672,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -659,7 +702,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_fieldy = f_addrsy(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -683,7 +729,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l, tMe) + call c_f_pointer(f_addrsx(l,tMe), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,tMe), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -716,8 +765,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -745,8 +796,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = domain%x(1)%domain_data%begin,is-1 @@ -763,7 +816,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -784,8 +840,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -795,7 +853,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -817,8 +878,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -841,8 +904,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) @@ -858,7 +923,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -879,8 +947,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u is = is + shift ie = ie + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -890,7 +960,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end do case(CGRID_NE) do l=1,l_size - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -912,8 +985,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -937,8 +1012,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) @@ -954,7 +1031,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) @@ -975,8 +1055,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -986,7 +1068,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) @@ -1008,8 +1093,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u do j = js ,je, midpoint if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -1033,8 +1120,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) @@ -1050,7 +1139,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) @@ -1071,8 +1163,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u js = js + shift je = je + shift do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) - ptr_fieldy = f_addrsy(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js,je fieldx(i,j,k) = -fieldx(i,j,k) @@ -1082,7 +1176,10 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end do case(CGRID_NE) do l=1,l_size - ptr_fieldx = f_addrsx(l, 1) + call c_f_pointer(f_addrsx(l,1), tmpptr, shape=shapex) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,1:ke_max) => tmpptr(:,:,:) + call c_f_pointer(f_addrsy(l,1), tmpptr, shape=shapey) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,1:ke_max) => tmpptr(:,:,:) do k = 1,ke_list(l,tMe) do j = js, je fieldx(i,j,k) = -fieldx(i,j,k) diff --git a/mpp/include/mpp_do_update_ad.fh b/mpp/include/mpp_do_update_ad.fh index e729ed6338..85a5f3deb3 100644 --- a/mpp/include/mpp_do_update_ad.fh +++ b/mpp/include/mpp_do_update_ad.fh @@ -25,22 +25,23 @@ !! ref: BN. Cheng, A Duality between Forward and Adjoint MPI Communication Routines !! COMPUTATIONAL METHODS IN SCIENCE AND TECHNOLOGY Special Issue 2006, 23-24 subroutine MPP_DO_UPDATE_AD_3D_( f_addrs, domain, update, d_type, ke, flags) - integer(i8_kind), intent(in) :: f_addrs(:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: update MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: ke integer, optional, intent(in) :: flags - MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke) - pointer(ptr_field, field) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape(3) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() character(len=8) :: text !equate to mpp_domains_stack - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - pointer( ptr, buffer ) + MPP_TYPE_, pointer :: buffer(:) integer :: buffer_pos !receive domains saved here for unpacking @@ -56,8 +57,9 @@ integer :: send_msgsize(MAXLIST) !>Send buffer msg size storage !!This should be checkpointed for reverse ad communication + shape = [update%xend-update%xbegin+1, update%yend-update%ybegin+1, ke] outunit = stdout() - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) l_size = size(f_addrs,1) update_flags = XUPDATE+YUPDATE !default @@ -209,7 +211,8 @@ pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -296,7 +299,8 @@ select case( overPtr%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -308,7 +312,8 @@ end do case( MINUS_NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -320,7 +325,8 @@ end do case( NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -332,7 +338,8 @@ end do case( ONE_HUNDRED_EIGHTY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l, tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = je, js, -1 do i = ie, is, -1 diff --git a/mpp/include/mpp_do_update_nest.fh b/mpp/include/mpp_do_update_nest.fh index a97d06492f..e39dfee0fa 100644 --- a/mpp/include/mpp_do_update_nest.fh +++ b/mpp/include/mpp_do_update_nest.fh @@ -20,15 +20,16 @@ !> @{ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, wb_addrs, eb_addrs, & sb_addrs, nb_addrs, flags, xbegin, xend, ybegin, yend) - integer(i8_kind), intent(in) :: f_addrs(:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrs(:) type(nest_level_type), intent(in) :: nest_domain type(nestSpec), intent(in) :: update MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: ke - integer(i8_kind), intent(in) :: wb_addrs(:) - integer(i8_kind), intent(in) :: eb_addrs(:) - integer(i8_kind), intent(in) :: sb_addrs(:) - integer(i8_kind), intent(in) :: nb_addrs(:) + type(c_ptr), intent(in) :: wb_addrs(:) + type(c_ptr), intent(in) :: eb_addrs(:) + type(c_ptr), intent(in) :: sb_addrs(:) + type(c_ptr), intent(in) :: nb_addrs(:) integer, intent(in) :: flags integer, intent(in) :: xbegin, xend, ybegin, yend @@ -40,19 +41,14 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, integer :: is, ie, js, je, l_size integer :: buffer_pos, msgsize integer :: buffer_recv_size, pos - MPP_TYPE_ :: field(xbegin:xend, ybegin:yend,ke) - MPP_TYPE_ :: wbuffer(update%west%is_you :update%west%ie_you, update%west%js_you :update%west%je_you, ke) - MPP_TYPE_ :: ebuffer(update%east%is_you :update%east%ie_you, update%east%js_you :update%east%je_you, ke) - MPP_TYPE_ :: sbuffer(update%south%is_you:update%south%ie_you, update%south%js_you:update%south%je_you,ke) - MPP_TYPE_ :: nbuffer(update%north%is_you:update%north%ie_you, update%north%js_you:update%north%je_you,ke) - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - - pointer(ptr_field, field) - pointer(ptr_buffer, buffer ) - pointer(ptr_wbuffer, wbuffer) - pointer(ptr_ebuffer, ebuffer) - pointer(ptr_sbuffer, sbuffer) - pointer(ptr_nbuffer, nbuffer) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer :: wbuffer(:,:,:) + MPP_TYPE_, pointer :: ebuffer(:,:,:) + MPP_TYPE_, pointer :: sbuffer(:,:,:) + MPP_TYPE_, pointer :: nbuffer(:,:,:) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_w(3), shape_e(3), shape_s(3), shape_n(3) recv(1) = BTEST(flags,EAST) recv(3) = BTEST(flags,SOUTH) @@ -61,8 +57,13 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, send = recv - ptr_buffer = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) l_size = size(f_addrs(:)) + shape_f = [xend-xbegin+1, yend-ybegin+1, ke] + shape_w = [update%west%ie_you -update%west%is_you +1, update%west%je_you -update%west%js_you +1, ke] + shape_e = [update%east%ie_you -update%east%is_you +1, update%east%je_you -update%east%js_you +1, ke] + shape_s = [update%south%ie_you-update%south%is_you+1, update%south%je_you-update%south%js_you+1, ke] + shape_n = [update%north%ie_you-update%north%is_you+1, update%north%je_you-update%north%js_you+1, ke] !--- pre-post receiving buffer_pos = 0 @@ -124,7 +125,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, select case(overPtr%rotation(n)) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l) + call c_f_pointer(f_addrs(l), tmpptr, shape=shape_f) + field(xbegin:xend, ybegin:yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -136,7 +138,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l) + call c_f_pointer(f_addrs(l), tmpptr, shape=shape_f) + field(xbegin:xend, ybegin:yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -148,7 +151,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, end do case(NINETY) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l) + call c_f_pointer(f_addrs(l), tmpptr, shape=shape_f) + field(xbegin:xend, ybegin:yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -199,7 +203,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, select case (dir) case ( 1 ) ! east do l=1,l_size ! loop over number of fields - ptr_ebuffer = eb_addrs(l) + call c_f_pointer(eb_addrs(l), tmpptr, shape=shape_e) + ebuffer(update%east%is_you :update%east%ie_you, update%east%js_you :update%east%je_you, 1:ke) & + => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -211,7 +217,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, end do case ( 3 ) ! south do l=1,l_size ! loop over number of fields - ptr_sbuffer = sb_addrs(l) + call c_f_pointer(sb_addrs(l), tmpptr, shape=shape_s) + sbuffer(update%south%is_you:update%south%ie_you, update%south%js_you:update%south%je_you, 1:ke) & + => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -223,7 +231,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, end do case ( 5 ) ! west do l=1,l_size ! loop over number of fields - ptr_wbuffer = wb_addrs(l) + call c_f_pointer(wb_addrs(l), tmpptr, shape=shape_w) + wbuffer(update%west%is_you :update%west%ie_you, update%west%js_you :update%west%je_you, 1:ke) & + => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -235,7 +245,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_(f_addrs, nest_domain, update, d_type, ke, end do case ( 7 ) ! north do l=1,l_size ! loop over number of fields - ptr_nbuffer = nb_addrs(l) + call c_f_pointer(nb_addrs(l), tmpptr, shape=shape_n) + nbuffer(update%north%is_you:update%north%ie_you, update%north%js_you:update%north%je_you, 1:ke) & + => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -261,15 +273,16 @@ end subroutine MPP_DO_UPDATE_NEST_FINE_3D_ #ifdef VECTOR_FIELD_ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update_x, update_y, d_type, ke, wb_addrsx, & wb_addrsy, eb_addrsx, eb_addrsy, sb_addrsx, sb_addrsy, nb_addrsx, nb_addrsy, flags) - integer(i8_kind), intent(in) :: f_addrsx(:), f_addrsy(:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrsx(:), f_addrsy(:) type(nest_level_type), intent(in) :: nest_domain type(nestSpec), intent(in) :: update_x, update_y MPP_TYPE_, intent(in) :: d_type ! creates unique interface integer, intent(in) :: ke - integer(i8_kind), intent(in) :: wb_addrsx(:), wb_addrsy(:) - integer(i8_kind), intent(in) :: eb_addrsx(:), eb_addrsy(:) - integer(i8_kind), intent(in) :: sb_addrsx(:), sb_addrsy(:) - integer(i8_kind), intent(in) :: nb_addrsx(:), nb_addrsy(:) + type(c_ptr), intent(in) :: wb_addrsx(:), wb_addrsy(:) + type(c_ptr), intent(in) :: eb_addrsx(:), eb_addrsy(:) + type(c_ptr), intent(in) :: sb_addrsx(:), sb_addrsy(:) + type(c_ptr), intent(in) :: nb_addrsx(:), nb_addrsy(:) integer, intent(in) :: flags character(len=8) :: text @@ -285,29 +298,21 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update integer :: from_pelist(update_x%nrecv+update_y%nrecv), to_pelist(update_x%nsend+update_y%nsend) integer :: start_pos_recv(update_x%nrecv+update_y%nrecv), start_pos_send(update_x%nsend+update_y%nsend) - MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke) - MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke) - MPP_TYPE_ :: wbufferx(update_x%west%is_you :update_x%west%ie_you, update_x%west%js_you :update_x%west%je_you, ke) - MPP_TYPE_ :: ebufferx(update_x%east%is_you :update_x%east%ie_you, update_x%east%js_you :update_x%east%je_you, ke) - MPP_TYPE_ :: sbufferx(update_x%south%is_you:update_x%south%ie_you, update_x%south%js_you:update_x%south%je_you,ke) - MPP_TYPE_ :: nbufferx(update_x%north%is_you:update_x%north%ie_you, update_x%north%js_you:update_x%north%je_you,ke) - MPP_TYPE_ :: wbuffery(update_y%west%is_you :update_y%west%ie_you, update_y%west%js_you :update_y%west%je_you, ke) - MPP_TYPE_ :: ebuffery(update_y%east%is_you :update_y%east%ie_you, update_y%east%js_you :update_y%east%je_you, ke) - MPP_TYPE_ :: sbuffery(update_y%south%is_you:update_y%south%ie_you, update_y%south%js_you:update_y%south%je_you,ke) - MPP_TYPE_ :: nbuffery(update_y%north%is_you:update_y%north%ie_you, update_y%north%js_you:update_y%north%je_you,ke) - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) - pointer(ptr_buffer, buffer ) - pointer(ptr_wbufferx, wbufferx) - pointer(ptr_ebufferx, ebufferx) - pointer(ptr_sbufferx, sbufferx) - pointer(ptr_nbufferx, nbufferx) - pointer(ptr_wbuffery, wbuffery) - pointer(ptr_ebuffery, ebuffery) - pointer(ptr_sbuffery, sbuffery) - pointer(ptr_nbuffery, nbuffery) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer :: wbufferx(:,:,:) + MPP_TYPE_, pointer :: ebufferx(:,:,:) + MPP_TYPE_, pointer :: sbufferx(:,:,:) + MPP_TYPE_, pointer :: nbufferx(:,:,:) + MPP_TYPE_, pointer :: wbuffery(:,:,:) + MPP_TYPE_, pointer :: ebuffery(:,:,:) + MPP_TYPE_, pointer :: sbuffery(:,:,:) + MPP_TYPE_, pointer :: nbuffery(:,:,:) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_fx(3), shape_fy(3) + integer :: shape_wx(3), shape_ex(3), shape_sx(3), shape_nx(3) + integer :: shape_wy(3), shape_ey(3), shape_sy(3), shape_ny(3) recv(1) = BTEST(flags,EAST) recv(3) = BTEST(flags,SOUTH) @@ -316,8 +321,18 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update send = recv - ptr_buffer = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) l_size = size(f_addrsx(:)) + shape_fx = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke] + shape_fy = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke] + shape_wx = [update_x%west%ie_you -update_x%west%is_you+1, update_x%west%je_you -update_x%west%js_you +1, ke] + shape_ex = [update_x%east%ie_you -update_x%east%is_you+1, update_x%east%je_you -update_x%east%js_you +1, ke] + shape_sx = [update_x%south%ie_you-update_x%south%is_you+1, update_x%south%je_you-update_x%south%js_you+1, ke] + shape_nx = [update_x%north%ie_you-update_x%north%is_you+1, update_x%north%je_you-update_x%north%js_you+1, ke] + shape_wy = [update_y%west%ie_you -update_y%west%is_you+1, update_y%west%je_you -update_y%west%js_you +1, ke] + shape_ey = [update_y%east%ie_you -update_y%east%is_you+1, update_y%east%je_you -update_y%east%js_you +1, ke] + shape_sy = [update_y%south%ie_you-update_y%south%is_you+1, update_y%south%je_you-update_y%south%js_you+1, ke] + shape_ny = [update_y%north%ie_you-update_y%north%is_you+1, update_y%north%je_you-update_y%north%js_you+1, ke] nrecv = get_nest_vector_recv(nest_domain, update_x, update_y, ind_recv_x, ind_recv_y, start_pos_recv, from_pelist) nsend = get_nest_vector_send(nest_domain, update_x, update_y, ind_send_x, ind_send_y, start_pos_send, to_pelist) @@ -394,7 +409,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update select case(update_x%send(ind_x)%rotation(n)) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l) + call c_f_pointer(f_addrsx(l), tmpptr, shape=shape_fx) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -407,7 +423,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update case(MINUS_NINETY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldy = f_addrsy(l) + call c_f_pointer(f_addrsy(l), tmpptr, shape=shape_fy) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -419,7 +436,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do else do l=1,l_size ! loop over number of fields - ptr_fieldy = f_addrsy(l) + call c_f_pointer(f_addrsy(l), tmpptr, shape=shape_fy) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -432,7 +450,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update endif case(NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldy = f_addrsy(l) + call c_f_pointer(f_addrsy(l), tmpptr, shape=shape_fy) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -460,7 +479,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update select case(update_y%send(ind_y)%rotation(n)) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldy = f_addrsy(l) + call c_f_pointer(f_addrsy(l), tmpptr, shape=shape_fy) + fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -472,7 +492,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l) + call c_f_pointer(f_addrsx(l), tmpptr, shape=shape_fx) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -485,7 +506,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update case(NINETY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l) + call c_f_pointer(f_addrsx(l), tmpptr, shape=shape_fx) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -497,7 +519,8 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do else do l=1,l_size ! loop over number of fields - ptr_fieldx = f_addrsx(l) + call c_f_pointer(f_addrsx(l), tmpptr, shape=shape_fx) + fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -552,7 +575,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update select case (dir) case ( 1 ) ! east do l=1,l_size ! loop over number of fields - ptr_ebuffery = eb_addrsy(l) + call c_f_pointer(eb_addrsy(l), tmpptr, shape=shape_ey) + ebuffery(update_y%east%is_you :update_y%east%ie_you, update_y%east%js_you :update_y%east%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -564,7 +589,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 3 ) ! south do l=1,l_size ! loop over number of fields - ptr_sbuffery = sb_addrsy(l) + call c_f_pointer(sb_addrsy(l), tmpptr, shape=shape_sy) + sbuffery(update_y%south%is_you:update_y%south%ie_you, update_y%south%js_you:update_y%south%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -576,7 +603,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 5 ) ! west do l=1,l_size ! loop over number of fields - ptr_wbuffery = wb_addrsy(l) + call c_f_pointer(wb_addrsy(l), tmpptr, shape=shape_wy) + wbuffery(update_y%west%is_you :update_y%west%ie_you, update_y%west%js_you :update_y%west%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -588,7 +617,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 7 ) ! north do l=1,l_size ! loop over number of fields - ptr_nbuffery = nb_addrsy(l) + call c_f_pointer(nb_addrsy(l), tmpptr, shape=shape_ny) + nbuffery(update_y%north%is_you:update_y%north%ie_you, update_y%north%js_you:update_y%north%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -615,7 +646,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update select case (dir) case ( 1 ) ! east do l=1,l_size ! loop over number of fields - ptr_ebufferx = eb_addrsx(l) + call c_f_pointer(eb_addrsx(l), tmpptr, shape=shape_ex) + ebufferx(update_x%east%is_you :update_x%east%ie_you, update_x%east%js_you :update_x%east%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -627,7 +660,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 3 ) ! south do l=1,l_size ! loop over number of fields - ptr_sbufferx = sb_addrsx(l) + call c_f_pointer(sb_addrsx(l), tmpptr, shape=shape_sx) + sbufferx(update_x%south%is_you:update_x%south%ie_you, update_x%south%js_you:update_x%south%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -639,7 +674,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 5 ) ! west do l=1,l_size ! loop over number of fields - ptr_wbufferx = wb_addrsx(l) + call c_f_pointer(wb_addrsx(l), tmpptr, shape=shape_wx) + wbufferx(update_x%west%is_you :update_x%west%ie_you, update_x%west%js_you :update_x%west%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -651,7 +688,9 @@ subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_(f_addrsx, f_addrsy, nest_domain, update end do case ( 7 ) ! north do l=1,l_size ! loop over number of fields - ptr_nbufferx = nb_addrsx(l) + call c_f_pointer(nb_addrsx(l), tmpptr, shape=shape_nx) + nbufferx(update_x%north%is_you:update_x%north%ie_you, update_x%north%js_you:update_x%north%je_you, 1:ke) => & + tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -680,8 +719,9 @@ end subroutine MPP_DO_UPDATE_NEST_FINE_3D_V_ !############################################################################### subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, update, d_type, ke) - integer(i8_kind), intent(in) :: f_addrs_in(:) - integer(i8_kind), intent(in) :: f_addrs_out(:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrs_in(:) + type(c_ptr), intent(in) :: f_addrs_out(:) type(nest_domain_type), intent(in) :: nest_domain type(nestSpec), intent(in) :: update MPP_TYPE_, intent(in) :: d_type ! creates unique interface @@ -694,16 +734,16 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, u integer :: is, ie, js, je, l_size integer :: buffer_pos, msgsize integer :: buffer_recv_size, pos - MPP_TYPE_ :: field_in(update%xbegin_c:update%xend_c, update%ybegin_c:update%yend_c,ke) - MPP_TYPE_ :: field_out(update%xbegin:update%xend, update%ybegin:update%yend,ke) - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) + MPP_TYPE_, pointer :: field_in(:,:,:) + MPP_TYPE_, pointer :: field_out(:,:,:) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_in(3), shape_out(3) - pointer(ptr_field_in, field_in) - pointer(ptr_field_out, field_out) - pointer(ptr_buffer, buffer ) - - ptr_buffer = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) l_size = size(f_addrs_in(:)) + shape_in = [update%xend_c-update%xbegin_c+1, update%yend_c-update%ybegin_c+1, ke] + shape_out = [update%xend-update%xbegin+1, update%yend-update%ybegin+1, ke] !--- pre-post receiving buffer_pos = 0 @@ -761,7 +801,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, u select case(overPtr%rotation(n)) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_field_in = f_addrs_in(l) + call c_f_pointer(f_addrs_in(l), tmpptr, shape=shape_in) + field_in(update%xbegin_c:update%xend_c, update%ybegin_c:update%yend_c, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -773,7 +814,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, u end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_field_in = f_addrs_in(l) + call c_f_pointer(f_addrs_in(l), tmpptr, shape=shape_in) + field_in(update%xbegin_c:update%xend_c, update%ybegin_c:update%yend_c, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -785,7 +827,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, u end do case(NINETY) do l=1,l_size ! loop over number of fields - ptr_field_in = f_addrs_in(l) + call c_f_pointer(f_addrs_in(l), tmpptr, shape=shape_in) + field_in(update%xbegin_c:update%xend_c, update%ybegin_c:update%yend_c, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -831,7 +874,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_(f_addrs_in, f_addrs_out, nest_domain, u pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_field_out = f_addrs_out(l) + call c_f_pointer(f_addrs_out(l), tmpptr, shape=shape_out) + field_out(update%xbegin:update%xend, update%ybegin:update%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -857,8 +901,9 @@ end subroutine MPP_DO_UPDATE_NEST_COARSE_3D_ !############################################################################### subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_out, f_addrsy_out, & nest_domain, nest, update_x, update_y, d_type, ke, flags) - integer(i8_kind), intent(in) :: f_addrsx_in(:), f_addrsy_in(:) - integer(i8_kind), intent(in) :: f_addrsx_out(:), f_addrsy_out(:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc + type(c_ptr), intent(in) :: f_addrsx_in(:), f_addrsy_in(:) + type(c_ptr), intent(in) :: f_addrsx_out(:), f_addrsy_out(:) type(nest_domain_type), intent(in) :: nest_domain type(nest_level_type), intent(in) :: nest type(nestSpec), intent(in) :: update_x, update_y @@ -878,19 +923,19 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou integer :: from_pelist(update_x%nrecv+update_y%nrecv), to_pelist(update_x%nsend+update_y%nsend) integer :: start_pos_recv(update_x%nrecv+update_y%nrecv), start_pos_send(update_x%nsend+update_y%nsend) - MPP_TYPE_ :: fieldx_in(update_x%xbegin_c:update_x%xend_c, update_x%ybegin_c:update_x%yend_c,ke) - MPP_TYPE_ :: fieldy_in(update_y%xbegin_c:update_y%xend_c, update_y%ybegin_c:update_y%yend_c,ke) - MPP_TYPE_ :: fieldx_out(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke) - MPP_TYPE_ :: fieldy_out(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke) - MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) - - pointer(ptr_fieldx_in, fieldx_in) - pointer(ptr_fieldy_in, fieldy_in) - pointer(ptr_fieldx_out, fieldx_out) - pointer(ptr_fieldy_out, fieldy_out) - pointer(ptr_buffer, buffer ) - - ptr_buffer = LOC(mpp_domains_stack) + MPP_TYPE_, pointer :: fieldx_in(:,:,:) + MPP_TYPE_, pointer :: fieldy_in(:,:,:) + MPP_TYPE_, pointer :: fieldx_out(:,:,:) + MPP_TYPE_, pointer :: fieldy_out(:,:,:) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_xin(3), shape_yin(3), shape_xout(3), shape_yout(3) + + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) + shape_xin = [update_x%xend_c-update_x%xbegin_c+1, update_x%yend_c-update_x%ybegin_c+1, ke] + shape_xin = [update_y%xend_c-update_y%xbegin_c+1, update_y%yend_c-update_y%ybegin_c+1, ke] + shape_xout = [update_x%xend-update_x%xbegin+1, update_x%yend-update_x%ybegin+1, ke] + shape_yout = [update_y%xend-update_y%xbegin+1, update_y%yend-update_y%ybegin+1, ke] l_size = size(f_addrsx_in(:)) nrecv = get_nest_vector_recv(nest, update_x, update_y, ind_recv_x, ind_recv_y, start_pos_recv, from_pelist) @@ -966,7 +1011,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou select case(update_x%send(ind_x)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldx_in = f_addrsx_in(l) + call c_f_pointer(f_addrsx_in(l), tmpptr, shape=shape_xin) + fieldx_in(update_x%xbegin_c:update_x%xend_c, update_x%ybegin_c:update_x%yend_c, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -980,7 +1026,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldy_in = f_addrsy_in(l) + call c_f_pointer(f_addrsy_in(l), tmpptr, shape=shape_yin) + fieldy_in(update_y%xbegin_c:update_y%xend_c, update_y%ybegin_c:update_y%yend_c, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -992,7 +1039,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou end do else do l=1,l_size ! loop over number of fields - ptr_fieldy_in = f_addrsy_in(l) + call c_f_pointer(f_addrsy_in(l), tmpptr, shape=shape_yin) + fieldy_in(update_y%xbegin_c:update_y%xend_c, update_y%ybegin_c:update_y%yend_c, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1005,7 +1053,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou endif case(NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldy_in = f_addrsy_in(l) + call c_f_pointer(f_addrsy_in(l), tmpptr, shape=shape_yin) + fieldy_in(update_y%xbegin_c:update_y%xend_c, update_y%ybegin_c:update_y%yend_c, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1029,7 +1078,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou select case(update_y%send(ind_y)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_fieldy_in = f_addrsy_in(l) + call c_f_pointer(f_addrsy_in(l), tmpptr, shape=shape_yin) + fieldy_in(update_y%xbegin_c:update_y%xend_c, update_y%ybegin_c:update_y%yend_c, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -1041,7 +1091,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou end do case(MINUS_NINETY) do l=1,l_size ! loop over number of fields - ptr_fieldx_in = f_addrsx_in(l) + call c_f_pointer(f_addrsx_in(l), tmpptr, shape=shape_xin) + fieldx_in(update_x%xbegin_c:update_x%xend_c, update_x%ybegin_c:update_x%yend_c, 1:ke) => tmpptr do k = 1,ke do i = is, ie do j = je, js, -1 @@ -1054,7 +1105,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou case(NINETY) if( BTEST(flags,SCALAR_BIT) ) then do l=1,l_size ! loop over number of fields - ptr_fieldx_in = f_addrsx_in(l) + call c_f_pointer(f_addrsx_in(l), tmpptr, shape=shape_xin) + fieldx_in(update_x%xbegin_c:update_x%xend_c, update_x%ybegin_c:update_x%yend_c, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1066,7 +1118,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou end do else do l=1,l_size ! loop over number of fields - ptr_fieldx_in = f_addrsx_in(l) + call c_f_pointer(f_addrsx_in(l), tmpptr, shape=shape_xin) + fieldx_in(update_x%xbegin_c:update_x%xend_c, update_x%ybegin_c:update_x%yend_c, 1:ke) => tmpptr do k = 1,ke do i = ie, is, -1 do j = js, je @@ -1115,7 +1168,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldy_out = f_addrsy_out(l) + call c_f_pointer(f_addrsy_out(l), tmpptr, shape=shape_yout) + fieldy_out(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie @@ -1136,7 +1190,8 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou pos = buffer_pos - msgsize buffer_pos = pos do l=1,l_size ! loop over number of fields - ptr_fieldx_out = f_addrsx_out(l) + call c_f_pointer(f_addrsx_out(l), tmpptr, shape=shape_xout) + fieldx_out(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend, 1:ke) => tmpptr do k = 1,ke do j = js, je do i = is, ie diff --git a/mpp/include/mpp_do_update_nonblock.fh b/mpp/include/mpp_do_update_nonblock.fh index 5090c780b6..1a9a8f4dbb 100644 --- a/mpp/include/mpp_do_update_nonblock.fh +++ b/mpp/include/mpp_do_update_nonblock.fh @@ -20,8 +20,9 @@ !> @{ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, ke_max, ke_list, flags, & & reuse_id_update, name) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc integer, intent(in) :: id_update - integer(i8_kind), intent(in) :: f_addrs(:,:) + type(c_ptr), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain type(overlapSpec), intent(in) :: update MPP_TYPE_, intent(in) :: d_type ! creates unique interface @@ -40,11 +41,11 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k integer :: request integer :: send_msgsize(MAXLIST) character(len=128) :: text - MPP_TYPE_ :: buffer(size(mpp_domains_stack_nonblock(:))) - MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke_max) - pointer( ptr, buffer ) - pointer(ptr_field, field) + MPP_TYPE_, pointer :: buffer(:), field(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape(3) + shape = [update%xend-update%xbegin+1, update%yend-update%ybegin+1, ke_max] update_edge_only = BTEST(flags, EDGEONLY) recv = .false. recv(1) = BTEST(flags,EAST) @@ -68,7 +69,7 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k l_size = size(f_addrs,1) ke_sum = sum(ke_list) - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), buffer, [size(mpp_domains_stack_nonblock)]) buffer_pos = nonblock_data(id_update)%recv_pos @@ -164,7 +165,7 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k ! send call mpp_clock_begin(send_pack_clock_nonblock) -!$OMP parallel do schedule(dynamic) default(shared) private(buffer_pos,pos,dir,tMe,is,ie,js,je,ptr_field,to_pe, & +!$OMP parallel do schedule(dynamic) default(shared) private(buffer_pos,pos,dir,tMe,is,ie,js,je,tmpptr,field,to_pe, & !$OMP msgsize,request) do m = 1, update%nsend send_msgsize(m) = 0 @@ -182,7 +183,8 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k select case( update%send(m)%rotation(n) ) case(ZERO) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l,tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie @@ -194,7 +196,8 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k enddo case( MINUS_NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l,tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = is, ie do j = je, js, -1 @@ -206,7 +209,8 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k end do case( NINETY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l,tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do i = ie, is, -1 @@ -219,7 +223,8 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k end do case( ONE_HUNDRED_EIGHTY ) do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l,tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = je, js, -1 do i = ie, is, -1 @@ -257,8 +262,9 @@ end subroutine MPP_START_DO_UPDATE_3D_ !############################################################################### subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, ke_max, ke_list, flags) + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc integer, intent(in) :: id_update - integer(i8_kind), intent(in) :: f_addrs(:,:) + type(c_ptr), intent(in) :: f_addrs(:,:) type(domain2d), intent(in) :: domain type(overlapSpec), intent(in) :: update integer, intent(in) :: ke_max @@ -272,11 +278,12 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type integer :: is, ie, js, je logical :: send(8), recv(8), update_edge_only integer :: l_size, ke_sum - MPP_TYPE_ :: recv_buffer(size(mpp_domains_stack_nonblock(:))) - MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke_max) - pointer( ptr, recv_buffer ) - pointer(ptr_field, field) + MPP_TYPE_, pointer :: recv_buffer(:) + MPP_TYPE_, pointer :: field(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape(3) + shape = [update%xend-update%xbegin+1, update%yend-update%ybegin+1, ke_max] update_edge_only = BTEST(flags, EDGEONLY) recv = .false. recv(1) = BTEST(flags,EAST) @@ -300,7 +307,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type ke_sum = sum(ke_list) l_size = size(f_addrs,1) - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), recv_buffer, [size(mpp_domains_stack_nonblock)]) count = update%nrecv if(count > 0) then @@ -320,7 +327,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type !--unpack the data call mpp_clock_begin(unpk_clock_nonblock) !$OMP parallel do schedule(dynamic) default(shared) private(dir,buffer_pos,pos,tMe,is,ie,js,je,msgsize, & -!$OMP ptr_field) +!$OMP tmpptr, field) do m = update%nrecv, 1, -1 if( update%recv(m)%count == 0 )cycle buffer_pos = nonblock_data(id_update)%buffer_pos_recv(m) + nonblock_data(id_update)%size_recv(m) @@ -336,7 +343,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type pos = buffer_pos - msgsize buffer_pos = pos do l=1, l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) + call c_f_pointer(f_addrs(l,tMe), tmpptr, shape=shape) + field(update%xbegin:update%xend, update%ybegin:update%yend,1:ke_max) => tmpptr do k = 1,ke_list(l,tMe) do j = js, je do i = is, ie diff --git a/mpp/include/mpp_domains_comm.inc b/mpp/include/mpp_domains_comm.inc index c4048c2637..1258f34f5a 100644 --- a/mpp/include/mpp_domains_comm.inc +++ b/mpp/include/mpp_domains_comm.inc @@ -26,11 +26,12 @@ !> @{ function mpp_redistribute_init_comm(domain_in,l_addrs_in, domain_out,l_addrs_out, & isize_in,jsize_in,ksize_in,isize_out,jsize_out,ksize_out) RESULT(d_comm) + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated type(DomainCommunicator2D), pointer :: d_comm type(domain2D),target, intent(in) :: domain_in - integer(i8_kind), intent(in) :: l_addrs_in(:) + type(c_ptr), intent(in) :: l_addrs_in(:) type(domain2D),target, intent(in) :: domain_out - integer(i8_kind), intent(in) :: l_addrs_out(:) + type(c_ptr), intent(in) :: l_addrs_out(:) integer, intent(in) :: isize_in integer, intent(in) :: jsize_in integer, intent(in) :: ksize_in @@ -81,7 +82,7 @@ ! Create unique domain identifier list_size = size(l_addrs_in(:)) - if(l_addrs_out(1) > 0)then + if(c_associated(l_addrs_out(1)))then domain_id = set_domain_id(domain_out%id,ke+list_size) else domain_id = set_domain_id(domain_in%id,ke+list_size) @@ -210,13 +211,13 @@ jsize_l, ksize,l_addr2,flags, position) RESULT(d_comm) type(DomainCommunicator2D), pointer :: d_comm type(domain2D),target, intent(in) :: domain - integer(i8_kind), intent(in) :: l_addr + type(c_ptr), intent(in) :: l_addr integer, intent(in) :: isize_g integer, intent(in) :: jsize_g integer, intent(in) :: isize_l integer, intent(in) :: jsize_l integer, intent(in) :: ksize - integer(i8_kind),optional,intent(in) :: l_addr2 + type(c_ptr), optional,intent(in) :: l_addr2 integer, optional, intent(in) :: flags integer, optional, intent(in) :: position @@ -434,15 +435,16 @@ subroutine mpp_redistribute_free_comm(domain_in,l_addr,domain_out,l_addr2,ksize,lsize) ! Since initialization of the d_comm type is expensive, freeing should be a rare ! event. Thus no attempt is made to salvage freed d_comm's. + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated type(domain2D), intent(in) :: domain_in - integer(i8_kind), intent(in) :: l_addr + type(c_ptr), intent(in) :: l_addr type(domain2D), intent(in) :: domain_out - integer(i8_kind), intent(in) :: l_addr2 + type(c_ptr), intent(in) :: l_addr2 integer, intent(in) :: ksize,lsize integer(i8_kind) :: domain_id - if(l_addr2 > 0)then + if(c_associated(l_addr2))then domain_id = set_domain_id(domain_out%id,ksize+lsize) else domain_id = set_domain_id(domain_in%id,ksize+lsize) @@ -455,9 +457,9 @@ ! Since initialization of the d_comm type is expensive, freeing should be a rare ! event. Thus no attempt is made to salvage freed d_comm's. type(domain2D), intent(in) :: domain - integer(i8_kind), intent(in) :: l_addr + type(c_ptr), intent(in) :: l_addr integer, intent(in) :: ksize - integer(i8_kind),optional,intent(in) :: l_addr2 + type(c_ptr), optional,intent(in) :: l_addr2 integer, optional,intent(in) :: flags integer :: update_flags @@ -472,9 +474,11 @@ subroutine free_comm(domain_id,l_addr,l_addr2) ! Since initialization of the d_comm type is expensive, freeing should be a rare ! event. Thus no attempt is made to salvage freed d_comm's. + use, intrinsic :: iso_c_binding, only: c_ptr + use mpp_mod, only: get_pointer_address integer(i8_kind), intent(in) :: domain_id - integer(i8_kind), intent(in) :: l_addr - integer(i8_kind),optional,intent(in) :: l_addr2 + type(c_ptr), intent(in) :: l_addr + type(c_ptr), optional,intent(in) :: l_addr2 integer(i8_kind) :: dc_key,a_key integer :: dc_idx,a_idx,i_idx,insert,insert_a,insert_i @@ -482,10 +486,10 @@ i_idx = find_key(domain_id,ids_sorted(1:n_ids),insert_i) - a_idx = find_key(l_addr,addrs_sorted(1:a_sort_len),insert_a) + a_idx = find_key(get_pointer_address(l_addr),addrs_sorted(1:a_sort_len),insert_a) a_key = int(addrs_idx(a_idx),KIND(i8_kind)) if(PRESENT(l_addr2))then - a2_idx = find_key(l_addr2,addrs2_sorted(1:a2_sort_len),insert_a2) + a2_idx = find_key(get_pointer_address(l_addr2),addrs2_sorted(1:a2_sort_len),insert_a2) a_key = a_key + ADDR2_BASE*int(addrs2_idx(a2_idx),KIND(i8_kind)) endif dc_key = DOMAIN_ID_BASE*int(ids_idx(i_idx),KIND(i8_kind)) + a_key @@ -502,9 +506,10 @@ function get_comm(domain_id,l_addr,l_addr2) + use mpp_mod, only: get_pointer_address integer(i8_kind),intent(in) :: domain_id - integer(i8_kind),intent(in) :: l_addr - integer(i8_kind),intent(in),optional :: l_addr2 + type(c_ptr), intent(in) :: l_addr + type(c_ptr), intent(in),optional :: l_addr2 type(DomainCommunicator2D), pointer :: get_comm integer(i8_kind) :: dc_key,a_key @@ -513,10 +518,10 @@ if(.not.ALLOCATED(d_comm))ALLOCATE(d_comm(MAX_FIELDS)) i_idx = find_key(domain_id,ids_sorted(1:n_ids),insert_i) - a_idx = find_key(l_addr,addrs_sorted(1:a_sort_len),insert_a) + a_idx = find_key(get_pointer_address(l_addr),addrs_sorted(1:a_sort_len),insert_a) a_key = int(addrs_idx(a_idx),KIND(i8_kind)) if(PRESENT(l_addr2))then - a2_idx = find_key(l_addr2,addrs2_sorted(1:a2_sort_len),insert_a2) + a2_idx = find_key(get_pointer_address(l_addr2),addrs2_sorted(1:a2_sort_len),insert_a2) a_key = a_key + ADDR2_BASE*int(addrs2_idx(a2_idx),KIND(i8_kind)) endif dc_key = DOMAIN_ID_BASE*int(ids_idx(i_idx),KIND(i8_kind)) + a_key @@ -536,7 +541,7 @@ call mpp_error(FATAL,'GET_COMM: Maximum number of memory addresses exceeded') endif n_addrs = n_addrs + 1 - a_idx = push_key(addrs_sorted,addrs_idx,a_sort_len,insert_a,l_addr,n_addrs) + a_idx = push_key(addrs_sorted,addrs_idx,a_sort_len,insert_a,get_pointer_address(l_addr),n_addrs) endif if(PRESENT(l_addr2))then if(a2_idx<0)then @@ -544,7 +549,7 @@ call mpp_error(FATAL,'GET_COMM: Maximum number of 2nd memory addresses exceeded') endif n_addrs2 = n_addrs2 + 1 - a2_idx = push_key(addrs2_sorted,addrs2_idx,a2_sort_len,insert_a2,l_addr2,n_addrs2) + a2_idx = push_key(addrs2_sorted,addrs2_idx,a2_sort_len,insert_a2,get_pointer_address(l_addr2),n_addrs2) endif endif if(n_comm == MAX_FIELDS)then @@ -667,9 +672,9 @@ d_comm%initialized=.false. d_comm%id=-9999 - d_comm%l_addr =-9999 - d_comm%l_addrx =-9999 - d_comm%l_addry =-9999 + d_comm%l_addr =c_null_ptr + d_comm%l_addrx =c_null_ptr + d_comm%l_addry =c_null_ptr if( allocated(d_comm%sendis) ) DEALLOCATE(d_comm%sendis); !!d_comm%sendis =>NULL() if( allocated(d_comm%sendie) ) DEALLOCATE(d_comm%sendie); !!d_comm%sendie =>NULL() diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index 64c20ed386..8b208494be 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -122,6 +122,7 @@ !##################################################################### subroutine init_nonblock_type( nonblock_obj ) + use, intrinsic :: iso_c_binding, only: c_null_ptr type(nonblock_type), intent(inout) :: nonblock_obj @@ -150,8 +151,8 @@ subroutine init_nonblock_type( nonblock_obj ) nonblock_obj%buffer_pos_send(:) = 0 nonblock_obj%buffer_pos_recv(:) = 0 nonblock_obj%nfields = 0 - nonblock_obj%field_addrs(:) = 0 - nonblock_obj%field_addrs2(:) = 0 + nonblock_obj%field_addrs(:) = c_null_ptr + nonblock_obj%field_addrs2(:) = c_null_ptr return diff --git a/mpp/include/mpp_get_boundary.fh b/mpp/include/mpp_get_boundary.fh index 800b238498..e31189d00d 100644 --- a/mpp/include/mpp_get_boundary.fh +++ b/mpp/include/mpp_get_boundary.fh @@ -22,16 +22,17 @@ !> This routine is used to retrieve scalar boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:) - MPP_TYPE_, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=c_null_ptr integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift @@ -84,41 +85,41 @@ subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) if(present(ebuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D: ebuffer should not be present when north is folded') if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: ebuffer should not be present') - b_addrs(1, list, tile) = LOC(ebuffer) + b_addrs(1, list, tile) = c_loc(ebuffer) buffer_size(1) = size(ebuffer(:)) else - b_addrs(1, list, tile) = 0 + b_addrs(1, list, tile) = c_null_ptr buffer_size(1) = 1 end if if(present(sbuffer)) then if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: sbuffer should not be present') - b_addrs(2, list, tile) = LOC(sbuffer) + b_addrs(2, list, tile) = c_loc(sbuffer) buffer_size(2) = size(sbuffer(:)) else - b_addrs(2, list, tile) = 0 + b_addrs(2, list, tile) = c_null_ptr buffer_size(2) = 1 end if if(present(wbuffer)) then if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: wbuffer should not be present') - b_addrs(3, list, tile) = LOC(wbuffer) + b_addrs(3, list, tile) = c_loc(wbuffer) buffer_size(3) = size(wbuffer(:)) else - b_addrs(3, list, tile) = 0 + b_addrs(3, list, tile) = c_null_ptr buffer_size(3) = 1 end if if(present(nbuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D: nbuffer should not be present when north is folded') if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: nbuffer should be be present') - b_addrs(4, list, tile) = LOC(nbuffer) + b_addrs(4, list, tile) = c_loc(nbuffer) buffer_size(4) = size(nbuffer(:)) else - b_addrs(4, list, tile) = 0 + b_addrs(4, list, tile) = c_null_ptr buffer_size(4) = 1 end if @@ -152,7 +153,7 @@ subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), & bsize, ksize, d_type) endif - l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrs=c_null_ptr; bsize=0; b_addrs=c_null_ptr; isize=0; jsize=0; ksize=0 end if return @@ -163,16 +164,17 @@ end subroutine MPP_GET_BOUNDARY_2D_ !############################################################################################### subroutine MPP_GET_BOUNDARY_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:,:) - MPP_TYPE_, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=c_null_ptr integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift @@ -225,41 +227,41 @@ subroutine MPP_GET_BOUNDARY_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) if(present(ebuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D: ebuffer should not be present when north is folded') if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: ebuffer should not be present') - b_addrs(1, list, tile) = LOC(ebuffer) + b_addrs(1, list, tile) = c_loc(ebuffer) buffer_size(1) = size(ebuffer,1) else - b_addrs(1, list, tile) = 0 + b_addrs(1, list, tile) = c_null_ptr buffer_size(1) = 1 end if if(present(sbuffer)) then if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: sbuffer should not be present') - b_addrs(2, list, tile) = LOC(sbuffer) + b_addrs(2, list, tile) = c_loc(sbuffer) buffer_size(2) = size(sbuffer,1) else - b_addrs(2, list, tile) = 0 + b_addrs(2, list, tile) = c_null_ptr buffer_size(2) = 1 end if if(present(wbuffer)) then if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: wbuffer should not be present') - b_addrs(3, list, tile) = LOC(wbuffer) + b_addrs(3, list, tile) = c_loc(wbuffer) buffer_size(3) = size(wbuffer,1) else - b_addrs(3, list, tile) = 0 + b_addrs(3, list, tile) = c_null_ptr buffer_size(3) = 1 end if if(present(nbuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D: nbuffer should not be present when north is folded') if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: nbuffer should not be present') - b_addrs(4, list, tile) = LOC(nbuffer) + b_addrs(4, list, tile) = c_loc(nbuffer) buffer_size(4) = size(nbuffer,1) else - b_addrs(4, list, tile) = 0 + b_addrs(4, list, tile) = c_null_ptr buffer_size(4) = 1 end if @@ -295,7 +297,7 @@ subroutine MPP_GET_BOUNDARY_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), & bsize, ksize, d_type) endif - l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrs=c_null_ptr; bsize=0; b_addrs=c_null_ptr; isize=0; jsize=0; ksize=0 end if end subroutine MPP_GET_BOUNDARY_3D_ @@ -306,10 +308,11 @@ end subroutine MPP_GET_BOUNDARY_3D_ subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, & ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, & complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:) - MPP_TYPE_, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:) - MPP_TYPE_, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:) integer, intent(in), optional :: flags, gridtype, tile_count logical, intent(in), optional :: complete @@ -317,10 +320,10 @@ subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=c_null_ptr integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0 integer, save :: offset_type, upflags integer :: bufferx_size(4), buffery_size(4) @@ -378,43 +381,43 @@ subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(present(ebufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present when north is folded') if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present') - b_addrsx(1, list, tile) = LOC(ebufferx) + b_addrsx(1, list, tile) = c_loc(ebufferx) bufferx_size(1) = size(ebufferx,1) else - b_addrsx(1, list, tile) = 0 + b_addrsx(1, list, tile) = c_null_ptr bufferx_size(1) = 1 end if if(present(sbufferx)) then if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbufferx should not be present') - b_addrsx(2, list, tile) = LOC(sbufferx) + b_addrsx(2, list, tile) = c_loc(sbufferx) bufferx_size(2) = size(sbufferx,1) else - b_addrsx(2, list, tile) = 0 + b_addrsx(2, list, tile) = c_null_ptr bufferx_size(2) = 1 end if if(present(wbufferx)) then if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbufferx should not be present') - b_addrsx(3, list, tile) = LOC(wbufferx) + b_addrsx(3, list, tile) = c_loc(wbufferx) bufferx_size(3) = size(wbufferx,1) else - b_addrsx(3, list, tile) = 0 + b_addrsx(3, list, tile) = c_null_ptr bufferx_size(3) = 1 end if if(present(nbufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present when north is folded') if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present') - b_addrsx(4, list, tile) = LOC(nbufferx) + b_addrsx(4, list, tile) = c_loc(nbufferx) bufferx_size(4) = size(nbufferx,1) else - b_addrsx(4, list, tile) = 0 + b_addrsx(4, list, tile) = c_null_ptr bufferx_size(4) = 1 end if @@ -422,36 +425,36 @@ subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present when north is folded') if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present') - b_addrsy(1, list, tile) = LOC(ebuffery) + b_addrsy(1, list, tile) = c_loc(ebuffery) buffery_size(1) = size(ebuffery,1) else - b_addrsy(1, list, tile) = 0 + b_addrsy(1, list, tile) = c_null_ptr buffery_size(1) = 1 end if if(present(sbuffery)) then if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbuffery should not be present') - b_addrsy(2, list, tile) = LOC(sbuffery) + b_addrsy(2, list, tile) = c_loc(sbuffery) buffery_size(2) = size(sbuffery,1) else - b_addrsy(2, list, tile) = 0 + b_addrsy(2, list, tile) = c_null_ptr buffery_size(2) = 1 end if if(present(wbuffery)) then if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbuffery should not be present') - b_addrsy(3, list, tile) = LOC(wbuffery) + b_addrsy(3, list, tile) = c_loc(wbuffery) buffery_size(3) = size(wbuffery,1) else - b_addrsy(3, list, tile) = 0 + b_addrsy(3, list, tile) = c_null_ptr buffery_size(3) = 1 end if if(present(nbuffery)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present when north is folded') if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present') - b_addrsy(4, list, tile) = LOC(nbuffery) + b_addrsy(4, list, tile) = c_loc(nbuffery) buffery_size(4) = size(nbuffery,1) else - b_addrsy(4, list, tile) = 0 + b_addrsy(4, list, tile) = c_null_ptr buffery_size(4) = 1 end if @@ -513,8 +516,8 @@ subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, & bsizey, ksize, d_type, update_flags, grid_offset_type) endif - l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0; - b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; bsizex=0; bsizey=0; + b_addrsx=c_null_ptr; b_addrsy=c_null_ptr; isize=0; jsize=0; ksize=0 end if @@ -527,11 +530,12 @@ end subroutine MPP_GET_BOUNDARY_2D_V_ subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, & ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, & complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: fieldx(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) - MPP_TYPE_, intent(in) :: fieldy(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) - MPP_TYPE_, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) - MPP_TYPE_, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldy(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) integer, intent(in), optional :: flags, gridtype, tile_count logical, intent(in), optional :: complete @@ -539,10 +543,10 @@ subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=c_null_ptr integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0 integer, save :: offset_type, upflags integer :: bufferx_size(4), buffery_size(4) @@ -600,43 +604,43 @@ subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(present(ebufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present when north is folded') if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present') - b_addrsx(1, list, tile) = LOC(ebufferx) + b_addrsx(1, list, tile) = c_loc(ebufferx) bufferx_size(1) = size(ebufferx,1) else - b_addrsx(1, list, tile) = 0 + b_addrsx(1, list, tile) = c_null_ptr bufferx_size(1) = 1 end if if(present(sbufferx)) then if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbufferx should not be present') - b_addrsx(2, list, tile) = LOC(sbufferx) + b_addrsx(2, list, tile) = c_loc(sbufferx) bufferx_size(2) = size(sbufferx,1) else - b_addrsx(2, list, tile) = 0 + b_addrsx(2, list, tile) = c_null_ptr bufferx_size(2) = 1 end if if(present(wbufferx)) then if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbufferx should not be present') - b_addrsx(3, list, tile) = LOC(wbufferx) + b_addrsx(3, list, tile) = c_loc(wbufferx) bufferx_size(3) = size(wbufferx,1) else - b_addrsx(3, list, tile) = 0 + b_addrsx(3, list, tile) = c_null_ptr bufferx_size(3) = 1 end if if(present(nbufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present when north is folded') if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present') - b_addrsx(4, list, tile) = LOC(nbufferx) + b_addrsx(4, list, tile) = c_loc(nbufferx) bufferx_size(4) = size(nbufferx,1) else - b_addrsx(4, list, tile) = 0 + b_addrsx(4, list, tile) = c_null_ptr bufferx_size(4) = 1 end if @@ -644,36 +648,36 @@ subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present when north is folded') if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present') - b_addrsy(1, list, tile) = LOC(ebuffery) + b_addrsy(1, list, tile) = c_loc(ebuffery) buffery_size(1) = size(ebuffery,1) else - b_addrsy(1, list, tile) = 0 + b_addrsy(1, list, tile) = c_null_ptr buffery_size(1) = 1 end if if(present(sbuffery)) then if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbuffery should not be present') - b_addrsy(2, list, tile) = LOC(sbuffery) + b_addrsy(2, list, tile) = c_loc(sbuffery) buffery_size(2) = size(sbuffery,1) else - b_addrsy(2, list, tile) = 0 + b_addrsy(2, list, tile) = c_null_ptr buffery_size(2) = 1 end if if(present(wbuffery)) then if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbuffery should not be present') - b_addrsy(3, list, tile) = LOC(wbuffery) + b_addrsy(3, list, tile) = c_loc(wbuffery) buffery_size(3) = size(wbuffery,1) else - b_addrsy(3, list, tile) = 0 + b_addrsy(3, list, tile) = c_null_ptr buffery_size(3) = 1 end if if(present(nbuffery)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present when north is folded') if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present') - b_addrsy(4, list, tile) = LOC(nbuffery) + b_addrsy(4, list, tile) = c_loc(nbuffery) buffery_size(4) = size(nbuffery,1) else - b_addrsy(4, list, tile) = 0 + b_addrsy(4, list, tile) = c_null_ptr buffery_size(4) = 1 end if @@ -737,8 +741,8 @@ subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wb b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, & bsizey, ksize, d_type, update_flags, grid_offset_type) endif - l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0; - b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; bsizex=0; bsizey=0; + b_addrsx=c_null_ptr; b_addrsy=c_null_ptr; isize=0; jsize=0; ksize=0 end if end subroutine MPP_GET_BOUNDARY_3D_V_ diff --git a/mpp/include/mpp_get_boundary_ad.fh b/mpp/include/mpp_get_boundary_ad.fh index fc8c62bc1d..66b29c562d 100644 --- a/mpp/include/mpp_get_boundary_ad.fh +++ b/mpp/include/mpp_get_boundary_ad.fh @@ -23,16 +23,17 @@ !> This routine is used to retrieve scalar ad boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:) - MPP_TYPE_, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=c_null_ptr integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift @@ -85,41 +86,41 @@ subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbu write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) if(present(ebuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D: ebuffer should not be present when north is folded') if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: ebuffer should not be present') - b_addrs(1, list, tile) = LOC(ebuffer) + b_addrs(1, list, tile) = c_loc(ebuffer) buffer_size(1) = size(ebuffer(:)) else - b_addrs(1, list, tile) = 0 + b_addrs(1, list, tile) = c_null_ptr buffer_size(1) = 1 end if if(present(sbuffer)) then if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: sbuffer should not be present') - b_addrs(2, list, tile) = LOC(sbuffer) + b_addrs(2, list, tile) = c_loc(sbuffer) buffer_size(2) = size(sbuffer(:)) else - b_addrs(2, list, tile) = 0 + b_addrs(2, list, tile) = c_null_ptr buffer_size(2) = 1 end if if(present(wbuffer)) then if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: wbuffer should not be present') - b_addrs(3, list, tile) = LOC(wbuffer) + b_addrs(3, list, tile) = c_loc(wbuffer) buffer_size(3) = size(wbuffer(:)) else - b_addrs(3, list, tile) = 0 + b_addrs(3, list, tile) = c_null_ptr buffer_size(3) = 1 end if if(present(nbuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D: nbuffer should not be present when north is folded') if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: nbuffer should be be present') - b_addrs(4, list, tile) = LOC(nbuffer) + b_addrs(4, list, tile) = c_loc(nbuffer) buffer_size(4) = size(nbuffer(:)) else - b_addrs(4, list, tile) = 0 + b_addrs(4, list, tile) = c_null_ptr buffer_size(4) = 1 end if @@ -153,7 +154,7 @@ subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbu call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), & bsize, ksize, d_type) endif - l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrs=c_null_ptr; bsize=0; b_addrs=c_null_ptr; isize=0; jsize=0; ksize=0 end if return @@ -164,16 +165,17 @@ end subroutine MPP_GET_BOUNDARY_AD_2D_ !############################################################################################### subroutine MPP_GET_BOUNDARY_AD_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:,:) - MPP_TYPE_, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:) integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=c_null_ptr integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift @@ -226,41 +228,41 @@ subroutine MPP_GET_BOUNDARY_AD_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbu write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) if(present(ebuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D: ebuffer should not be present when north is folded') if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: ebuffer should not be present') - b_addrs(1, list, tile) = LOC(ebuffer) + b_addrs(1, list, tile) = c_loc(ebuffer) buffer_size(1) = size(ebuffer,1) else - b_addrs(1, list, tile) = 0 + b_addrs(1, list, tile) = c_null_ptr buffer_size(1) = 1 end if if(present(sbuffer)) then if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: sbuffer should not be present') - b_addrs(2, list, tile) = LOC(sbuffer) + b_addrs(2, list, tile) = c_loc(sbuffer) buffer_size(2) = size(sbuffer,1) else - b_addrs(2, list, tile) = 0 + b_addrs(2, list, tile) = c_null_ptr buffer_size(2) = 1 end if if(present(wbuffer)) then if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: wbuffer should not be present') - b_addrs(3, list, tile) = LOC(wbuffer) + b_addrs(3, list, tile) = c_loc(wbuffer) buffer_size(3) = size(wbuffer,1) else - b_addrs(3, list, tile) = 0 + b_addrs(3, list, tile) = c_null_ptr buffer_size(3) = 1 end if if(present(nbuffer)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D: nbuffer should not be present when north is folded') if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: nbuffer should not be present') - b_addrs(4, list, tile) = LOC(nbuffer) + b_addrs(4, list, tile) = c_loc(nbuffer) buffer_size(4) = size(nbuffer,1) else - b_addrs(4, list, tile) = 0 + b_addrs(4, list, tile) = c_null_ptr buffer_size(4) = 1 end if @@ -296,7 +298,7 @@ subroutine MPP_GET_BOUNDARY_AD_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbu call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), & bsize, ksize, d_type) endif - l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrs=c_null_ptr; bsize=0; b_addrs=c_null_ptr; isize=0; jsize=0; ksize=0 end if end subroutine MPP_GET_BOUNDARY_AD_3D_ @@ -307,10 +309,11 @@ end subroutine MPP_GET_BOUNDARY_AD_3D_ subroutine MPP_GET_BOUNDARY_AD_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, & ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, & complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:) - MPP_TYPE_, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:) - MPP_TYPE_, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:) integer, intent(in), optional :: flags, gridtype, tile_count logical, intent(in), optional :: complete @@ -318,10 +321,10 @@ subroutine MPP_GET_BOUNDARY_AD_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=c_null_ptr integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0 integer, save :: offset_type, upflags integer :: bufferx_size(4), buffery_size(4) @@ -379,43 +382,43 @@ subroutine MPP_GET_BOUNDARY_AD_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(present(ebufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present when north is folded') if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present') - b_addrsx(1, list, tile) = LOC(ebufferx) + b_addrsx(1, list, tile) = c_loc(ebufferx) bufferx_size(1) = size(ebufferx,1) else - b_addrsx(1, list, tile) = 0 + b_addrsx(1, list, tile) = c_null_ptr bufferx_size(1) = 1 end if if(present(sbufferx)) then if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbufferx should not be present') - b_addrsx(2, list, tile) = LOC(sbufferx) + b_addrsx(2, list, tile) = c_loc(sbufferx) bufferx_size(2) = size(sbufferx,1) else - b_addrsx(2, list, tile) = 0 + b_addrsx(2, list, tile) = c_null_ptr bufferx_size(2) = 1 end if if(present(wbufferx)) then if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbufferx should not be present') - b_addrsx(3, list, tile) = LOC(wbufferx) + b_addrsx(3, list, tile) = c_loc(wbufferx) bufferx_size(3) = size(wbufferx,1) else - b_addrsx(3, list, tile) = 0 + b_addrsx(3, list, tile) = c_null_ptr bufferx_size(3) = 1 end if if(present(nbufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present when north is folded') if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present') - b_addrsx(4, list, tile) = LOC(nbufferx) + b_addrsx(4, list, tile) = c_loc(nbufferx) bufferx_size(4) = size(nbufferx,1) else - b_addrsx(4, list, tile) = 0 + b_addrsx(4, list, tile) = c_null_ptr bufferx_size(4) = 1 end if @@ -423,36 +426,36 @@ subroutine MPP_GET_BOUNDARY_AD_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present when north is folded') if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present') - b_addrsy(1, list, tile) = LOC(ebuffery) + b_addrsy(1, list, tile) = c_loc(ebuffery) buffery_size(1) = size(ebuffery,1) else - b_addrsy(1, list, tile) = 0 + b_addrsy(1, list, tile) = c_null_ptr buffery_size(1) = 1 end if if(present(sbuffery)) then if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbuffery should not be present') - b_addrsy(2, list, tile) = LOC(sbuffery) + b_addrsy(2, list, tile) = c_loc(sbuffery) buffery_size(2) = size(sbuffery,1) else - b_addrsy(2, list, tile) = 0 + b_addrsy(2, list, tile) = c_null_ptr buffery_size(2) = 1 end if if(present(wbuffery)) then if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbuffery should not be present') - b_addrsy(3, list, tile) = LOC(wbuffery) + b_addrsy(3, list, tile) = c_loc(wbuffery) buffery_size(3) = size(wbuffery,1) else - b_addrsy(3, list, tile) = 0 + b_addrsy(3, list, tile) = c_null_ptr buffery_size(3) = 1 end if if(present(nbuffery)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present when north is folded') if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present') - b_addrsy(4, list, tile) = LOC(nbuffery) + b_addrsy(4, list, tile) = c_loc(nbuffery) buffery_size(4) = size(nbuffery,1) else - b_addrsy(4, list, tile) = 0 + b_addrsy(4, list, tile) = c_null_ptr buffery_size(4) = 1 end if @@ -514,8 +517,8 @@ subroutine MPP_GET_BOUNDARY_AD_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, & bsizey, ksize, d_type, update_flags, grid_offset_type) endif - l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0; - b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; bsizex=0; bsizey=0; + b_addrsx=c_null_ptr; b_addrsy=c_null_ptr; isize=0; jsize=0; ksize=0 end if @@ -528,11 +531,12 @@ end subroutine MPP_GET_BOUNDARY_AD_2D_V_ subroutine MPP_GET_BOUNDARY_AD_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, & ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, & complete, tile_count) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: fieldx(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) - MPP_TYPE_, intent(in) :: fieldy(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) - MPP_TYPE_, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) - MPP_TYPE_, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldy(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:) + MPP_TYPE_, target, contiguous, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:) integer, intent(in), optional :: flags, gridtype, tile_count logical, intent(in), optional :: complete @@ -540,10 +544,10 @@ subroutine MPP_GET_BOUNDARY_AD_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999 - integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=c_null_ptr + type(c_ptr),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=c_null_ptr integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0 integer, save :: offset_type, upflags integer :: bufferx_size(4), buffery_size(4) @@ -601,43 +605,43 @@ subroutine MPP_GET_BOUNDARY_AD_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(present(ebufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present when north is folded') if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present') - b_addrsx(1, list, tile) = LOC(ebufferx) + b_addrsx(1, list, tile) = c_loc(ebufferx) bufferx_size(1) = size(ebufferx,1) else - b_addrsx(1, list, tile) = 0 + b_addrsx(1, list, tile) = c_null_ptr bufferx_size(1) = 1 end if if(present(sbufferx)) then if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbufferx should not be present') - b_addrsx(2, list, tile) = LOC(sbufferx) + b_addrsx(2, list, tile) = c_loc(sbufferx) bufferx_size(2) = size(sbufferx,1) else - b_addrsx(2, list, tile) = 0 + b_addrsx(2, list, tile) = c_null_ptr bufferx_size(2) = 1 end if if(present(wbufferx)) then if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbufferx should not be present') - b_addrsx(3, list, tile) = LOC(wbufferx) + b_addrsx(3, list, tile) = c_loc(wbufferx) bufferx_size(3) = size(wbufferx,1) else - b_addrsx(3, list, tile) = 0 + b_addrsx(3, list, tile) = c_null_ptr bufferx_size(3) = 1 end if if(present(nbufferx)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present when north is folded') if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present') - b_addrsx(4, list, tile) = LOC(nbufferx) + b_addrsx(4, list, tile) = c_loc(nbufferx) bufferx_size(4) = size(nbufferx,1) else - b_addrsx(4, list, tile) = 0 + b_addrsx(4, list, tile) = c_null_ptr bufferx_size(4) = 1 end if @@ -645,36 +649,36 @@ subroutine MPP_GET_BOUNDARY_AD_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present when north is folded') if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present') - b_addrsy(1, list, tile) = LOC(ebuffery) + b_addrsy(1, list, tile) = c_loc(ebuffery) buffery_size(1) = size(ebuffery,1) else - b_addrsy(1, list, tile) = 0 + b_addrsy(1, list, tile) = c_null_ptr buffery_size(1) = 1 end if if(present(sbuffery)) then if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbuffery should not be present') - b_addrsy(2, list, tile) = LOC(sbuffery) + b_addrsy(2, list, tile) = c_loc(sbuffery) buffery_size(2) = size(sbuffery,1) else - b_addrsy(2, list, tile) = 0 + b_addrsy(2, list, tile) = c_null_ptr buffery_size(2) = 1 end if if(present(wbuffery)) then if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbuffery should not be present') - b_addrsy(3, list, tile) = LOC(wbuffery) + b_addrsy(3, list, tile) = c_loc(wbuffery) buffery_size(3) = size(wbuffery,1) else - b_addrsy(3, list, tile) = 0 + b_addrsy(3, list, tile) = c_null_ptr buffery_size(3) = 1 end if if(present(nbuffery)) then if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, & 'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present when north is folded') if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present') - b_addrsy(4, list, tile) = LOC(nbuffery) + b_addrsy(4, list, tile) = c_loc(nbuffery) buffery_size(4) = size(nbuffery,1) else - b_addrsy(4, list, tile) = 0 + b_addrsy(4, list, tile) = c_null_ptr buffery_size(4) = 1 end if @@ -738,8 +742,8 @@ subroutine MPP_GET_BOUNDARY_AD_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, & bsizey, ksize, d_type, update_flags, grid_offset_type) endif - l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0; - b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; bsizex=0; bsizey=0; + b_addrsx=c_null_ptr; b_addrsy=c_null_ptr; isize=0; jsize=0; ksize=0 end if end subroutine MPP_GET_BOUNDARY_AD_3D_V_ diff --git a/mpp/include/mpp_global_field.fh b/mpp/include/mpp_global_field.fh index 044f6f8050..2125dadda5 100644 --- a/mpp/include/mpp_global_field.fh +++ b/mpp/include/mpp_global_field.fh @@ -21,21 +21,19 @@ !! local field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:) - MPP_TYPE_, intent(out) :: global(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:,:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),1) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),1) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) ! initialize output, check if type macro logical - global = MPP_TYPE_INIT_VALUE - lptr = LOC( local) - gptr = LOC(global) + global = MPP_TYPE_INIT_VALUE + local3D (1:size( local,1),1:size( local,2),1:1) => local(:,:) + global3D(1:size(global,1),1:size(global,2),1:1) => global(:,:) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_2D_ @@ -80,39 +78,35 @@ subroutine MPP_GLOBAL_FIELD_4D_( domain, local, global, flags, position,tile_count, default_data ) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size(local,4)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) global = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2),1:size( local,3)*size( local,4)) => local(:,:,:,:) + global3D(1:size(global,1),1:size(global,2),1:size(global,3)*size(global,4)) => global(:,:,:,:) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_4D_ subroutine MPP_GLOBAL_FIELD_5D_( domain, local, global, flags, position,tile_count, default_data ) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:,:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size( local,4)*size(local,5)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) global = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2),1:size( local,3)*size( local,4)*size(local,5)) => local(:,:,:,:,:) + global3D(1:size(global,1),1:size(global,2),1:size(global,3)*size(global,4)*size(local,5)) => global(:,:,:,:,:) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_5D_ !> @} diff --git a/mpp/include/mpp_global_field_ad.fh b/mpp/include/mpp_global_field_ad.fh index d4f560959d..37b452c2ae 100644 --- a/mpp/include/mpp_global_field_ad.fh +++ b/mpp/include/mpp_global_field_ad.fh @@ -24,20 +24,18 @@ !! global field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_AD_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(out) :: local(:,:) - MPP_TYPE_, intent(in) :: global(:,:) + MPP_TYPE_, target, contiguous, intent(out) :: local(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: global(:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),1) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),1) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) local = MPP_TYPE_INIT_VALUE - lptr = LOC( local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2),1:1) => local(:,:) + global3D(1:size(global,1),1:size(global,2),1:1) => global(:,:) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_2D_AD_ @@ -63,39 +61,35 @@ subroutine MPP_GLOBAL_FIELD_4D_AD_( domain, local, global, flags, position,tile_count, default_data ) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(out) :: local(:,:,:,:) - MPP_TYPE_, intent(in) :: global(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: local(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: global(:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size(local,4)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) local = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2),1:size( local,3)*size( local,4)) => local(:,:,:,:) + global3D(1:size(global,1),1:size(global,2),1:size(global,3)*size(global,4)) => global(:,:,:,:) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_4D_AD_ subroutine MPP_GLOBAL_FIELD_5D_AD_( domain, local, global, flags, position,tile_count, default_data ) type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(out) :: local(:,:,:,:,:) - MPP_TYPE_, intent(in) :: global(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: local(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: global(:,:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size( local,4)*size(local,5)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:,:) + MPP_TYPE_, pointer :: global3D(:,:,:) local = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2),1:size( local,3)*size( local,4)*size(local,5)) => local(:,:,:,:,:) + global3D(1:size(global,1),1:size(global,2),1:size(global,3)*size(global,4)*size(local,5)) => global(:,:,:,:,:) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) end subroutine MPP_GLOBAL_FIELD_5D_AD_ !> @} diff --git a/mpp/include/mpp_global_field_ug.fh b/mpp/include/mpp_global_field_ug.fh index 07f2eb2d3a..fa1b666656 100644 --- a/mpp/include/mpp_global_field_ug.fh +++ b/mpp/include/mpp_global_field_ug.fh @@ -19,18 +19,16 @@ !> @{ subroutine MPP_GLOBAL_FIELD_UG_2D_( domain, local, global, flags, default_data) type(domainUG), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:) - MPP_TYPE_, intent(out) :: global(:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:) integer, intent(in), optional :: flags MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),1) - MPP_TYPE_ :: global3D(size(global,1),1) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:) + MPP_TYPE_, pointer :: global3D(:,:) global = 0 - lptr = LOC( local) - gptr = LOC(global) + local3D (1:size( local,1),1:1) => local(:) + global3D(1:size(global,1),1:1) => global(:) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) end subroutine MPP_GLOBAL_FIELD_UG_2D_ @@ -38,6 +36,7 @@ subroutine MPP_GLOBAL_FIELD_UG_3D_( domain, local, global, flags, default_data) !get a global field from a local field !local field may be on compute OR data domain + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(domainUG), intent(in) :: domain MPP_TYPE_, intent(in) :: local(domain%compute%begin:,:) MPP_TYPE_, intent(out) :: global(domain%global%begin:,:) @@ -48,14 +47,12 @@ integer :: ke, lsc, lec, ls, le, num_word_me integer :: ipos, jpos logical :: root_only, global_on_this_pe - MPP_TYPE_ :: clocal (domain%compute%size*size(local,2)) - MPP_TYPE_ :: cremote(domain%compute%max_size*size(local,2)) + MPP_TYPE_, pointer :: clocal (:) + MPP_TYPE_, pointer :: cremote(:) + integer :: local_stack_size, remote_stack_size integer :: stackuse character(len=8) :: text - pointer( ptr_local, clocal ) - pointer( ptr_remote, cremote ) - stackuse = size(clocal(:))+size(cremote(:)) if( stackuse.GT.mpp_domains_stack_size )then write( text, '(i8)' )stackuse @@ -65,8 +62,10 @@ end if mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse ) - ptr_local = LOC(mpp_domains_stack) - ptr_remote = LOC(mpp_domains_stack(size(clocal(:))+1)) + local_stack_size = domain%compute%size*size(local,2) + remote_stack_size = domain%compute%max_size*size(local,2) + call c_f_pointer(c_loc(mpp_domains_stack(1)), clocal, [local_stack_size ]) + call c_f_pointer(c_loc(mpp_domains_stack(local_stack_size+1)), cremote, [remote_stack_size]) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD_UG: must first call mpp_domains_init.' ) @@ -170,35 +169,31 @@ subroutine MPP_GLOBAL_FIELD_UG_4D_( domain, local, global, flags, default_data ) type(domainUG), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:,:,:) integer, intent(in), optional :: flags MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2)*size( local,3)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2)*size(global,3)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:) + MPP_TYPE_, pointer :: global3D(:,:) global = 0 - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2)*size( local,3)) => local(:,:,:) + global3D(1:size(global,1),1:size(global,2)*size(global,3)) => global(:,:,:) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) end subroutine MPP_GLOBAL_FIELD_UG_4D_ subroutine MPP_GLOBAL_FIELD_UG_5D_( domain, local, global, flags, default_data ) type(domainUG), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: local(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: global(:,:,:,:) integer, intent(in), optional :: flags MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2)*size( local,3)*size( local,4)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2)*size(global,3)*size(global,4)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) + MPP_TYPE_, pointer :: local3D (:,:) + MPP_TYPE_, pointer :: global3D(:,:) global = 0 - lptr = LOC(local) - gptr = LOC(global) + local3D (1:size( local,1),1:size( local,2)*size( local,3)*size( local,4)) => local(:,:,:,:) + global3D(1:size(global,1),1:size(global,2)*size(global,3)*size(global,4)) => global(:,:,:,:) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) end subroutine MPP_GLOBAL_FIELD_UG_5D_ !> @} diff --git a/mpp/include/mpp_global_reduce.fh b/mpp/include/mpp_global_reduce.fh index a777cd2940..4a5de4b561 100644 --- a/mpp/include/mpp_global_reduce.fh +++ b/mpp/include/mpp_global_reduce.fh @@ -20,13 +20,12 @@ function MPP_GLOBAL_REDUCE_2D_( domain, field, locus, position ) MPP_TYPE_ :: MPP_GLOBAL_REDUCE_2D_ type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:) integer, intent(out), optional :: locus(2) integer, intent(in), optional :: position - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) + MPP_TYPE_, pointer :: field3D(:,:,:) integer :: locus3D(3) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) if( PRESENT(locus) )then MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D, position ) locus = locus3D(1:2) @@ -94,14 +93,13 @@ function MPP_GLOBAL_REDUCE_4D_( domain, field, locus, position ) MPP_TYPE_ :: MPP_GLOBAL_REDUCE_4D_ type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:,:) integer, intent(out), optional :: locus(4) integer, intent(in), optional :: position - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) + MPP_TYPE_, pointer :: field3D(:,:,:) integer :: locus3D(3) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) if( PRESENT(locus) )then MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D, position ) locus(1:2) = locus3D(1:2) @@ -120,14 +118,13 @@ function MPP_GLOBAL_REDUCE_5D_( domain, field, locus, position ) MPP_TYPE_ :: MPP_GLOBAL_REDUCE_5D_ type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: field(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:,:,:) integer, intent(out), optional :: locus(5) integer, intent(in), optional :: position - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5)) + MPP_TYPE_, pointer :: field3D(:,:,:) integer :: locus3D(3) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)*size(field,5)) => field(:,:,:,:,:) if( PRESENT(locus) )then MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D, position ) locus(1:2) = locus3D(1:2) diff --git a/mpp/include/mpp_group_update.fh b/mpp/include/mpp_group_update.fh index c1eadcaf71..a6c3600b3c 100644 --- a/mpp/include/mpp_group_update.fh +++ b/mpp/include/mpp_group_update.fh @@ -21,15 +21,14 @@ subroutine MPP_CREATE_GROUP_UPDATE_2D_(group, field, domain, flags, position, & whalo, ehalo, shalo, nhalo) type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo + MPP_TYPE_, pointer :: field3D(:,:,:) - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:1) => field call mpp_create_group_update(group, field3D, domain, flags, position, whalo, ehalo, shalo, nhalo) @@ -38,8 +37,9 @@ subroutine MPP_CREATE_GROUP_UPDATE_2D_(group, field, domain, flags, position, & end subroutine MPP_CREATE_GROUP_UPDATE_2D_ subroutine MPP_CREATE_GROUP_UPDATE_3D_(group, field, domain, flags, position, whalo, ehalo, shalo, nhalo) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: field(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags integer, intent(in), optional :: position @@ -109,7 +109,7 @@ subroutine MPP_CREATE_GROUP_UPDATE_3D_(group, field, domain, flags, position, wh isize = size(field,1); jsize=size(field,2); ksize = size(field,3) - group%addrs_s(nscalar) = LOC(field) + group%addrs_s(nscalar) = c_loc(field) if( group%nscalar == 1 ) then group%flags_s = update_flags group%whalo_s = update_whalo @@ -171,15 +171,14 @@ end subroutine MPP_CREATE_GROUP_UPDATE_3D_ subroutine MPP_CREATE_GROUP_UPDATE_4D_(group, field, domain, flags, position, & whalo, ehalo, shalo, nhalo) type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo + MPP_TYPE_, pointer :: field3D(:,:,:) - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field call mpp_create_group_update(group, field3D, domain, flags, position, whalo, ehalo, shalo, nhalo) @@ -191,16 +190,14 @@ subroutine MPP_CREATE_GROUP_UPDATE_2D_V_( group, fieldx, fieldy, domain, flags, whalo, ehalo, shalo, nhalo) type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy call mpp_create_group_update(group, field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo) @@ -213,8 +210,9 @@ end subroutine MPP_CREATE_GROUP_UPDATE_2D_V_ subroutine MPP_CREATE_GROUP_UPDATE_3D_V_( group, fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -290,8 +288,8 @@ subroutine MPP_CREATE_GROUP_UPDATE_3D_V_( group, fieldx, fieldy, domain, flags, if(ksize_x .NE. ksize_y) call mpp_error(FATAL, & 'MPP_CREATE_GROUP_UPDATE_V: mismatch of ksize between fieldx and fieldy') - group%addrs_x(nvector) = LOC(fieldx) - group%addrs_y(nvector) = LOC(fieldy) + group%addrs_x(nvector) = c_loc(fieldx) + group%addrs_y(nvector) = c_loc(fieldy) if( group%nvector == 1 ) then group%flags_v = update_flags @@ -399,16 +397,14 @@ subroutine MPP_CREATE_GROUP_UPDATE_4D_V_( group, fieldx, fieldy, domain, flags, whalo, ehalo, shalo, nhalo) type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy call mpp_create_group_update(group, field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo) @@ -419,6 +415,7 @@ end subroutine MPP_CREATE_GROUP_UPDATE_4D_V_ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(mpp_group_update_type), intent(inout) :: group type(domain2D), intent(inout) :: domain MPP_TYPE_, intent(in) :: d_type @@ -433,14 +430,16 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) integer :: shift, gridtype, midpoint integer :: npack, nunpack, rotation, isd - MPP_TYPE_ :: buffer(mpp_domains_stack_size) - MPP_TYPE_ :: field (group%is_s:group%ie_s,group%js_s:group%je_s, group%ksize_s) - MPP_TYPE_ :: fieldx(group%is_x:group%ie_x,group%js_x:group%je_x, group%ksize_v) - MPP_TYPE_ :: fieldy(group%is_y:group%ie_y,group%js_y:group%je_y, group%ksize_v) - pointer(ptr, buffer ) - pointer(ptr_field, field) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer :: field (:,:,:) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_x(3), shape_y(3) + + shape_f = [group%ie_s-group%is_s+1, group%je_s-group%js_s+1, group%ksize_s] + shape_x = [group%ie_x-group%is_x+1, group%je_x-group%js_x+1, group%ksize_v] + shape_y = [group%ie_y-group%is_y+1, group%je_y-group%js_y+1, group%ksize_v] nscalar = group%nscalar nvector = group%nvector @@ -462,7 +461,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) endif if(nvector > 0) recv_y = group%recv_y - ptr = LOC(mpp_domains_stack) + call c_f_pointer(c_loc(mpp_domains_stack), buffer, [size(mpp_domains_stack)]) !--- set reset_index_s and reset_index_v to 0 group%reset_index_s = 0 @@ -535,8 +534,10 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -562,8 +563,10 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) @@ -579,7 +582,8 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = isd,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -599,8 +603,10 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) is = is + shift ie = ie + shift do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -610,7 +616,8 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) end do case(CGRID_NE) do l=1,nvector - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -635,6 +642,7 @@ end subroutine MPP_DO_GROUP_UPDATE_ subroutine MPP_START_GROUP_UPDATE_(group, domain, d_type, reuse_buffer) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(mpp_group_update_type), intent(inout) :: group type(domain2D), intent(inout) :: domain MPP_TYPE_, intent(in) :: d_type @@ -649,14 +657,16 @@ subroutine MPP_START_GROUP_UPDATE_(group, domain, d_type, reuse_buffer) logical :: reuse_buf_pos character(len=8) :: text - MPP_TYPE_ :: buffer(size(mpp_domains_stack_nonblock(:))) - MPP_TYPE_ :: field (group%is_s:group%ie_s,group%js_s:group%je_s, group%ksize_s) - MPP_TYPE_ :: fieldx(group%is_x:group%ie_x,group%js_x:group%je_x, group%ksize_v) - MPP_TYPE_ :: fieldy(group%is_y:group%ie_y,group%js_y:group%je_y, group%ksize_v) - pointer( ptr, buffer ) - pointer(ptr_field, field) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer :: field (:,:,:) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_x(3), shape_y(3) + + shape_f = [group%ie_s-group%is_s+1, group%je_s-group%js_s+1, group%ksize_s] + shape_x = [group%ie_x-group%is_x+1, group%je_x-group%js_x+1, group%ksize_v] + shape_y = [group%ie_y-group%is_y+1, group%je_y-group%js_y+1, group%ksize_v] nscalar = group%nscalar nvector = group%nvector @@ -695,7 +705,7 @@ subroutine MPP_START_GROUP_UPDATE_(group, domain, d_type, reuse_buffer) nrecv = group%nrecv nsend = group%nsend - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), buffer, [size(mpp_domains_stack_nonblock)]) ! Make sure it is not in the middle of the old version of non-blocking halo update. if(num_update>0) call mpp_error(FATAL, "MPP_START_GROUP_UPDATE: can not be called in the middle of "// & @@ -743,6 +753,7 @@ subroutine MPP_START_GROUP_UPDATE_(group, domain, d_type, reuse_buffer) end subroutine MPP_START_GROUP_UPDATE_ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc type(mpp_group_update_type), intent(inout) :: group type(domain2D), intent(inout) :: domain MPP_TYPE_, intent(in) :: d_type @@ -753,14 +764,16 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) integer :: shift, gridtype, midpoint, flags_v integer :: nunpack, rotation, buffer_start_pos, nk, isd logical :: recv_y(8) - MPP_TYPE_ :: buffer(size(mpp_domains_stack_nonblock(:))) - MPP_TYPE_ :: field (group%is_s:group%ie_s,group%js_s:group%je_s, group%ksize_s) - MPP_TYPE_ :: fieldx(group%is_x:group%ie_x,group%js_x:group%je_x, group%ksize_v) - MPP_TYPE_ :: fieldy(group%is_y:group%ie_y,group%js_y:group%je_y, group%ksize_v) - pointer(ptr, buffer ) - pointer(ptr_field, field) - pointer(ptr_fieldx, fieldx) - pointer(ptr_fieldy, fieldy) + MPP_TYPE_, pointer :: buffer(:) + MPP_TYPE_, pointer :: field (:,:,:) + MPP_TYPE_, pointer :: fieldx(:,:,:) + MPP_TYPE_, pointer :: fieldy(:,:,:) + MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:) + integer :: shape_f(3), shape_x(3), shape_y(3) + + shape_f = [group%ie_s-group%is_s+1, group%je_s-group%js_s+1, group%ksize_s] + shape_x = [group%ie_x-group%is_x+1, group%je_x-group%js_x+1, group%ksize_v] + shape_y = [group%ie_y-group%is_y+1, group%je_y-group%js_y+1, group%ksize_v] gridtype = group%gridtype flags_v = group%flags_v @@ -774,7 +787,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) ksize = group%ksize_v endif if(nvector > 0) recv_y = group%recv_y - ptr = LOC(mpp_domains_stack_nonblock) + call c_f_pointer(c_loc(mpp_domains_stack_nonblock), buffer, [size(mpp_domains_stack_nonblock)]) if(num_nonblock_group_update < 1) call mpp_error(FATAL, & 'mpp_start_group_update must be called before calling mpp_end_group_update') @@ -811,8 +824,10 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) do i = is ,ie, midpoint if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize fieldx(i,j,k) = 0. fieldy(i,j,k) = 0. @@ -838,8 +853,10 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) @@ -855,7 +872,8 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = isd,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) @@ -875,8 +893,10 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) is = is + shift ie = ie + shift do l=1,nvector - ptr_fieldx = group%addrs_x(l) - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_x(l), tmpptr, shape=shape_x) + fieldx(group%is_x:group%ie_x,group%js_x:group%je_x,1:group%ksize_v) => tmpptr + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = is,ie fieldx(i,j,k) = -fieldx(i,j,k) @@ -886,7 +906,8 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) end do case(CGRID_NE) do l=1,nvector - ptr_fieldy = group%addrs_y(l) + call c_f_pointer(group%addrs_y(l), tmpptr, shape=shape_y) + fieldy(group%is_y:group%ie_y,group%js_y:group%je_y,1:group%ksize_v) => tmpptr do k = 1,ksize do i = is, ie fieldy(i,j,k) = -fieldy(i,j,k) @@ -914,8 +935,9 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) end subroutine MPP_COMPLETE_GROUP_UPDATE_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_(group, field) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:) group%reset_index_s = group%reset_index_s + 1 @@ -924,13 +946,14 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_(group, field) if(size(field,1) .NE. group%isize_s .OR. size(field,2) .NE. group%jsize_s .OR. group%ksize_s .NE. 1) & call mpp_error(FATAL, "MPP_RESET_GROUP_UPDATE_FIELD_2D_: size of field does not match the size stored in group") - group%addrs_s(group%reset_index_s) = LOC(field) + group%addrs_s(group%reset_index_s) = c_loc(field) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_(group, field) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: field(:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:) group%reset_index_s = group%reset_index_s + 1 @@ -939,13 +962,14 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_(group, field) if(size(field,1) .NE. group%isize_s .OR. size(field,2) .NE. group%jsize_s .OR. size(field,3) .NE. group%ksize_s) & call mpp_error(FATAL, "MPP_RESET_GROUP_UPDATE_FIELD_3D_: size of field does not match the size stored in group") - group%addrs_s(group%reset_index_s) = LOC(field) + group%addrs_s(group%reset_index_s) = c_loc(field) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_(group, field) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:,:) group%reset_index_s = group%reset_index_s + 1 @@ -955,14 +979,15 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_(group, field) size(field,3)*size(field,4) .NE. group%ksize_s) & call mpp_error(FATAL, "MPP_RESET_GROUP_UPDATE_FIELD_4D_: size of field does not match the size stored in group") - group%addrs_s(group%reset_index_s) = LOC(field) + group%addrs_s(group%reset_index_s) = c_loc(field) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_V_(group, fieldx, fieldy) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:), fieldy(:,:) group%reset_index_v = group%reset_index_v + 1 @@ -975,15 +1000,16 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_V_(group, fieldx, fieldy) call mpp_error(FATAL, & & "MPP_RESET_GROUP_UPDATE_FIELD_2D_V_: size of fieldy does not match the size stored in group") - group%addrs_x(group%reset_index_v) = LOC(fieldx) - group%addrs_y(group%reset_index_v) = LOC(fieldy) + group%addrs_x(group%reset_index_v) = c_loc(fieldx) + group%addrs_y(group%reset_index_v) = c_loc(fieldy) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_V_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_V_(group, fieldx, fieldy) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:,:), fieldy(:,:,:) group%reset_index_v = group%reset_index_v + 1 @@ -996,15 +1022,16 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_V_(group, fieldx, fieldy) call mpp_error(FATAL, & & "MPP_RESET_GROUP_UPDATE_FIELD_3D_V_: size of fieldy does not match the size stored in group") - group%addrs_x(group%reset_index_v) = LOC(fieldx) - group%addrs_y(group%reset_index_v) = LOC(fieldy) + group%addrs_x(group%reset_index_v) = c_loc(fieldx) + group%addrs_y(group%reset_index_v) = c_loc(fieldy) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_V_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_V_(group, fieldx, fieldy) + use, intrinsic :: iso_c_binding, only: c_loc type(mpp_group_update_type), intent(inout) :: group - MPP_TYPE_, intent(in) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:,:,:), fieldy(:,:,:,:) group%reset_index_v = group%reset_index_v + 1 @@ -1019,8 +1046,8 @@ subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_V_(group, fieldx, fieldy) call mpp_error(FATAL, & & "MPP_RESET_GROUP_UPDATE_FIELD_4D_V_: size of fieldy does not match the size stored in group") - group%addrs_x(group%reset_index_v) = LOC(fieldx) - group%addrs_y(group%reset_index_v) = LOC(fieldy) + group%addrs_x(group%reset_index_v) = c_loc(fieldx) + group%addrs_y(group%reset_index_v) = c_loc(fieldy) end subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_V_ !> @} diff --git a/mpp/include/mpp_sum.inc b/mpp/include/mpp_sum.inc index d81125a7a6..b7d1525c44 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 ad07137859..f78f38baad 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 1c445ed0c5..84354d8e16 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 df7b4f262c..344fa41780 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 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( get_pointer_address(c_loc(get_data)) /= get_pointer_address(c_loc(put_data)) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) diff --git a/mpp/include/mpp_unstruct_pass_data.fh b/mpp/include/mpp_unstruct_pass_data.fh index 1c5076cd66..66dda18984 100644 --- a/mpp/include/mpp_unstruct_pass_data.fh +++ b/mpp/include/mpp_unstruct_pass_data.fh @@ -22,14 +22,13 @@ !! First only implement for data at grid cell center. SUBROUTINE mpp_pass_SG_to_UG_2D_(UG_domain, field_SG, field_UG) type(domainUG), intent(in) :: UG_domain - MPP_TYPE_, intent(inout) :: field_UG(:) - MPP_TYPE_, intent(in) :: field_SG(:,:) - MPP_TYPE_ :: field3D_SG(size(field_SG,1),size(field_SG,2),1) - MPP_TYPE_ :: field2D_UG(size(field_UG(:)), 1) - pointer(ptr_SG, field3D_SG) - pointer(ptr_UG, field2D_UG) - ptr_SG = LOC(field_SG) - ptr_UG = LOC(field_UG) + MPP_TYPE_, target, contiguous, intent(inout) :: field_UG(:) + MPP_TYPE_, target, contiguous, intent(in) :: field_SG(:,:) + MPP_TYPE_, pointer :: field3D_SG(:,:,:), field2D_UG(:,:) + + field3D_SG(1:size(field_SG,1),1:size(field_SG,2),1:1) => field_SG + field2D_UG(1:size(field_UG(:)), 1:1) => field_UG + call mpp_pass_SG_to_UG(UG_domain, field3D_SG, field2D_UG) end SUBROUTINE mpp_pass_SG_to_UG_2D_ @@ -125,14 +124,12 @@ end SUBROUTINE mpp_pass_SG_to_UG_3D_ !! First only implement for data at grid cell center. SUBROUTINE mpp_pass_UG_to_SG_2D_(UG_domain, field_UG, field_SG) type(domainUG), intent(in) :: UG_domain - MPP_TYPE_, intent(in) :: field_UG(:) - MPP_TYPE_, intent(inout) :: field_SG(:,:) - MPP_TYPE_ :: field3D_SG(size(field_SG,1),size(field_SG,2),1) - MPP_TYPE_ :: field2D_UG(size(field_UG(:)), 1) - pointer(ptr_SG, field3D_SG) - pointer(ptr_UG, field2D_UG) - ptr_SG = LOC(field_SG) - ptr_UG = LOC(field_UG) + MPP_TYPE_, target, contiguous, intent(in) :: field_UG(:) + MPP_TYPE_, target, contiguous, intent(inout) :: field_SG(:,:) + MPP_TYPE_, pointer :: field3D_SG(:,:,:), field2D_UG(:,:) + + field3D_SG(1:size(field_SG,1),1:size(field_SG,2),1:1) => field_SG + field2D_UG(1:size(field_UG(:)), 1:1) => field_UG call mpp_pass_UG_to_SG(UG_domain, field2D_UG, field3D_SG) diff --git a/mpp/include/mpp_update_domains2D.fh b/mpp/include/mpp_update_domains2D.fh index b9b0a95e09..ed1aaf204e 100644 --- a/mpp/include/mpp_update_domains2D.fh +++ b/mpp/include/mpp_update_domains2D.fh @@ -21,7 +21,7 @@ !> Updates data domain of 2D field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) - MPP_TYPE_, intent(inout) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -30,9 +30,10 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) + call mpp_update_domains( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) return @@ -41,7 +42,8 @@ !> Updates data domain of 3D field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) - MPP_TYPE_, intent(inout) :: field(:,:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -52,7 +54,7 @@ integer :: update_position, update_whalo, update_ehalo, update_shalo, update_nhalo, ntile - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrs=c_null_ptr integer :: tile, max_ntile character(len=3) :: text logical :: set_mismatch, is_complete @@ -122,7 +124,7 @@ write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_UPDATE_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) update_position = CENTER if(present(position)) update_position = position if(list == 1 .AND. tile == 1 )then @@ -169,7 +171,7 @@ end if - l_size=0; f_addrs=-9999; isize=0; jsize=0; ke=0 + l_size=0; f_addrs=c_null_ptr; isize=0; jsize=0; ke=0 endif return @@ -178,7 +180,7 @@ !> Updates data domain of 4D field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) - MPP_TYPE_, intent(inout) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous,intent(inout) :: field(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -187,9 +189,9 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) call mpp_update_domains( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -198,7 +200,7 @@ !> Updates data domain of 5D field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) - MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -207,10 +209,9 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5)) + MPP_TYPE_, pointer :: field3D(:,:,:) - pointer( ptr, field3D ) - ptr = LOC(field) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)*size(field,5)) => field(:,:,:,:,:) call mpp_update_domains( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) return @@ -219,22 +220,22 @@ subroutine MPP_REDISTRIBUTE_2D_( domain_in, field_in, domain_out, field_out, complete, free, list_size, & & dc_handle, position ) type(domain2D), intent(in) :: domain_in, domain_out - MPP_TYPE_, intent(in) :: field_in (:,:) - MPP_TYPE_, intent(out) :: field_out(:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field_in (:,:) + MPP_TYPE_, target, contiguous, intent(out) :: field_out(:,:) logical, intent(in), optional :: complete, free integer, intent(in), optional :: list_size integer, intent(in), optional :: position - MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),1) - MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),1) + MPP_TYPE_, pointer :: field3D_in (:,:,:) + MPP_TYPE_, pointer :: field3D_out(:,:,:) type(DomainCommunicator2D),pointer,optional :: dc_handle - pointer( ptr_in, field3D_in ) - pointer( ptr_out, field3D_out ) field_out = 0 - ptr_in = 0 - ptr_out = 0 - if(domain_in%initialized) ptr_in = LOC(field_in ) - if(domain_out%initialized) ptr_out = LOC(field_out) + field3D_in => null() + field3D_out => null() + if(domain_in%initialized) & + field3D_in (1:size(field_in, 1),1:size(field_in, 2),1:1) => field_in (:,:) + if(domain_out%initialized) & + field3D_out(1:size(field_out,1),1:size(field_out,2),1:1) => field_out(:,:) call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out, complete, free, list_size, & & dc_handle, position ) @@ -244,9 +245,10 @@ subroutine MPP_REDISTRIBUTE_3D_( domain_in, field_in, domain_out, field_out, complete, free, list_size, & & dc_handle, position ) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc, c_associated type(domain2D), intent(in) :: domain_in, domain_out - MPP_TYPE_, intent(in) :: field_in (:,:,:) - MPP_TYPE_, intent(out) :: field_out(:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field_in (:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: field_out(:,:,:) logical, intent(in), optional :: complete, free integer, intent(in), optional :: list_size integer, intent(in), optional :: position @@ -254,19 +256,19 @@ type(DomainCommunicator2D),pointer,save :: d_comm =>NULL() logical :: do_redist,free_comm integer :: lsize - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: l_addrs_in=-9999, l_addrs_out=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: l_addrs_in=c_null_ptr, l_addrs_out=c_null_ptr integer, save :: isize_in=0,jsize_in=0,ke_in=0,l_size=0 integer, save :: isize_out=0,jsize_out=0,ke_out=0 logical :: set_mismatch integer :: ke character(len=2) :: text MPP_TYPE_ :: d_type - integer(i8_kind) :: floc_in, floc_out + type(c_ptr) :: floc_in, floc_out - floc_in = 0 - floc_out = 0 - if(domain_in%initialized) floc_in = LOC(field_in) - if(domain_out%initialized) floc_out = LOC(field_out) + floc_in = c_null_ptr + floc_out = c_null_ptr + if(domain_in%initialized) floc_in = c_loc(field_in) + if(domain_out%initialized) floc_out = c_loc(field_out) if(present(position)) then if(position .NE. CENTER) call mpp_error( FATAL, & @@ -277,7 +279,7 @@ free_comm=.false.; if(PRESENT(free))free_comm=free if(free_comm)then l_addrs_in(1) = floc_in; l_addrs_out(1) = floc_out - if(l_addrs_out(1)>0)then + if(c_associated(l_addrs_out(1)))then ke = size(field_out,3) else ke = size(field_in,3) @@ -292,24 +294,27 @@ end if l_addrs_in(l_size) = floc_in; l_addrs_out(l_size) = floc_out if(l_size == 1)then - if(l_addrs_in(l_size) > 0)then + if(c_associated(l_addrs_in(l_size)))then isize_in=size(field_in,1); jsize_in=size(field_in,2); ke_in = size(field_in,3) end if - if(l_addrs_out(l_size) > 0)then + if(c_associated(l_addrs_out(l_size)))then isize_out=size(field_out,1); jsize_out=size(field_out,2); ke_out = size(field_out,3) endif else set_mismatch = .false. - set_mismatch = l_addrs_in(l_size) == 0 .AND. l_addrs_in(l_size-1) /= 0 - set_mismatch = set_mismatch .OR. (l_addrs_in(l_size) > 0 .AND. l_addrs_in(l_size-1) == 0) - set_mismatch = set_mismatch .OR. (l_addrs_out(l_size) == 0 .AND. l_addrs_out(l_size-1) /= 0) - set_mismatch = set_mismatch .OR. (l_addrs_out(l_size) > 0 .AND. l_addrs_out(l_size-1) == 0) - if(l_addrs_in(l_size) > 0)then + set_mismatch = .NOT. c_associated(l_addrs_in(l_size)) .AND. c_associated(l_addrs_in(l_size-1)) + set_mismatch = set_mismatch .OR. & + (c_associated(l_addrs_in(l_size)) .AND. .NOT. c_associated(l_addrs_in(l_size-1))) + set_mismatch = set_mismatch .OR. & + (.NOT. c_associated(l_addrs_out(l_size)) .AND. c_associated(l_addrs_out(l_size-1))) + set_mismatch = set_mismatch .OR. & + (c_associated(l_addrs_out(l_size)) .AND. .NOT. c_associated(l_addrs_out(l_size-1))) + if(c_associated(l_addrs_in(l_size)))then set_mismatch = set_mismatch .OR. (isize_in /= size(field_in,1)) set_mismatch = set_mismatch .OR. (jsize_in /= size(field_in,2)) set_mismatch = set_mismatch .OR. (ke_in /= size(field_in,3)) endif - if(l_addrs_out(l_size) > 0)then + if(c_associated(l_addrs_out(l_size)))then set_mismatch = set_mismatch .OR. (isize_out /= size(field_out,1)) set_mismatch = set_mismatch .OR. (jsize_out /= size(field_out,2)) set_mismatch = set_mismatch .OR. (ke_out /= size(field_out,3)) @@ -328,7 +333,7 @@ if(PRESENT(dc_handle))dc_handle =>d_comm ! User wants to keep pointer to d_comm endif call mpp_do_redistribute( l_addrs_in(1:l_size), l_addrs_out(1:l_size), d_comm, d_type ) - l_size=0; l_addrs_in=-9999; l_addrs_out=-9999 + l_size=0; l_addrs_in=c_null_ptr; l_addrs_out=c_null_ptr isize_in=0; jsize_in=0; ke_in=0 isize_out=0; jsize_out=0; ke_out=0 d_comm =>NULL() @@ -341,22 +346,22 @@ subroutine MPP_REDISTRIBUTE_4D_( domain_in, field_in, domain_out, field_out, complete, free, list_size, & & dc_handle, position ) type(domain2D), intent(in) :: domain_in, domain_out - MPP_TYPE_, intent(in) :: field_in (:,:,:,:) - MPP_TYPE_, intent(out) :: field_out(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field_in (:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: field_out(:,:,:,:) logical, intent(in), optional :: complete, free integer, intent(in), optional :: list_size integer, intent(in), optional :: position - MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)*size(field_in ,4)) - MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4)) + MPP_TYPE_, pointer :: field3D_in (:,:,:) + MPP_TYPE_, pointer :: field3D_out(:,:,:) type(DomainCommunicator2D),pointer,optional :: dc_handle - pointer( ptr_in, field3D_in ) - pointer( ptr_out, field3D_out ) field_out = 0 - ptr_in = 0 - ptr_out = 0 - if(domain_in%initialized) ptr_in = LOC(field_in ) - if(domain_out%initialized) ptr_out = LOC(field_out) + field3D_in => null() + field3D_out => null() + if(domain_in%initialized) & + field3D_in (1:size(field_in, 1),1:size(field_in, 2),1:size(field_in ,3)*size(field_in ,4)) => field_in (:,:,:,:) + if(domain_out%initialized) & + field3D_out(1:size(field_out,1),1:size(field_out,2),1:size(field_out,3)*size(field_out,4)) => field_out(:,:,:,:) call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out, complete, free, list_size, & & dc_handle, position ) @@ -366,25 +371,24 @@ subroutine MPP_REDISTRIBUTE_5D_( domain_in, field_in, domain_out, field_out, complete, free, list_size, & & dc_handle, position ) type(domain2D), intent(in) :: domain_in, domain_out - MPP_TYPE_, intent(in) :: field_in (:,:,:,:,:) - MPP_TYPE_, intent(out) :: field_out(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(in) :: field_in (:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(out) :: field_out(:,:,:,:,:) logical, intent(in), optional :: complete, free integer, intent(in), optional :: list_size integer, intent(in), optional :: position - MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2), & - & size(field_in ,3)*size(field_in,4)*size(field_in ,5)) - MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2), & - & size(field_out,3)*size(field_out,4)*size(field_out,5)) - + MPP_TYPE_, pointer :: field3D_in (:,:,:) + MPP_TYPE_, pointer :: field3D_out(:,:,:) type(DomainCommunicator2D),pointer,optional :: dc_handle - pointer( ptr_in, field3D_in ) - pointer( ptr_out, field3D_out ) field_out = 0 - ptr_in = 0 - ptr_out = 0 - if(domain_in%initialized) ptr_in = LOC(field_in ) - if(domain_out%initialized) ptr_out = LOC(field_out) + field3D_in => null() + field3D_out => null() + if(domain_in%initialized) & + field3D_in (1:size(field_in, 1),1:size(field_in, 2),1:size(field_in ,3)*size(field_in ,4)*size(field_in ,5)) => & + field_in (:,:,:,:,:) + if(domain_out%initialized) & + field3D_out(1:size(field_out,1),1:size(field_out,2),1:size(field_out,3)*size(field_out,4)*size(field_out,5)) => & + field_out(:,:,:,:,:) call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out, complete, free, list_size, & & dc_handle, position ) @@ -398,20 +402,19 @@ subroutine MPP_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) !updates data domain of 2D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) - type(domain2D), intent(inout) :: domain - integer, intent(in), optional :: flags, gridtype - logical, intent(in), optional :: complete - integer, intent(in), optional :: whalo, ehalo, shalo, nhalo - character(len=*), intent(in), optional :: name - integer, intent(in), optional :: tile_count - - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:), fieldy(:,:) + type(domain2D), intent(inout) :: domain + integer, intent(in), optional :: flags, gridtype + logical, intent(in), optional :: complete + integer, intent(in), optional :: whalo, ehalo, shalo, nhalo + character(len=*), intent(in), optional :: name + integer, intent(in), optional :: tile_count + + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx(:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy(:,:) call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -421,7 +424,8 @@ subroutine MPP_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) !updates data domain of 3D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -433,7 +437,7 @@ integer :: grid_offset_type logical :: exchange_uv - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrsx=-9999, f_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrsx=c_null_ptr, f_addrsy=c_null_ptr logical :: do_update, is_complete integer, save :: isize(2)=0,jsize(2)=0,ke=0,l_size=0, offset_type=0, list=0 integer, save :: whalosz, ehalosz, shalosz, nhalosz @@ -514,8 +518,8 @@ call mpp_error(FATAL,'MPP_UPDATE_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(list == 1 .AND. tile == 1)then isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2); ke = size(fieldx,3) @@ -585,7 +589,7 @@ d_type,ke,grid_offset_type, flags) end if end if - l_size=0; f_addrsx=-9999; f_addrsy=-9999; isize=0; jsize=0; ke=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; isize=0; jsize=0; ke=0 end if return @@ -595,7 +599,7 @@ subroutine MPP_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) !updates data domain of 4D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -603,13 +607,12 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx(:,:,:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy(:,:,:,:) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -618,7 +621,7 @@ subroutine MPP_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) !updates data domain of 5D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -626,12 +629,12 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) => fieldx(:,:,:,:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) => fieldy(:,:,:,:,:) + call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) diff --git a/mpp/include/mpp_update_domains2D_ad.fh b/mpp/include/mpp_update_domains2D_ad.fh index b17e8e7f90..3e4af50377 100644 --- a/mpp/include/mpp_update_domains2D_ad.fh +++ b/mpp/include/mpp_update_domains2D_ad.fh @@ -21,7 +21,7 @@ !> Updates data domain of 2D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) - MPP_TYPE_, intent(inout) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -30,9 +30,9 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) + call mpp_update_domains_ad( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) return @@ -41,7 +41,8 @@ !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) - MPP_TYPE_, intent(inout) :: field(:,:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -52,7 +53,7 @@ integer :: update_position, update_whalo, update_ehalo, update_shalo, update_nhalo, ntile - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrs=c_null_ptr integer :: tile, max_ntile character(len=3) :: text logical :: set_mismatch, is_complete @@ -122,7 +123,7 @@ write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_UPDATE_AD_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) update_position = CENTER if(present(position)) update_position = position if(list == 1 .AND. tile == 1 )then @@ -169,7 +170,7 @@ end if - l_size=0; f_addrs=-9999; isize=0; jsize=0; ke=0 + l_size=0; f_addrs=c_null_ptr; isize=0; jsize=0; ke=0 endif return @@ -178,7 +179,7 @@ !> Updates data domain of 4D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) - MPP_TYPE_, intent(inout) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -187,9 +188,9 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) + call mpp_update_domains_ad( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -198,7 +199,7 @@ !> Updates data domain of 5D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) - MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags logical, intent(in), optional :: complete @@ -207,10 +208,9 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5)) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)*size(field,5)) => field(:,:,:,:,:) - pointer( ptr, field3D ) - ptr = LOC(field) call mpp_update_domains_ad( field3D, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) return @@ -224,7 +224,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) !updates data domain of 2D ad field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -232,12 +232,11 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx(:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy(:,:) + call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -247,7 +246,8 @@ subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) !updates data domain of 3D ad field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -259,7 +259,7 @@ integer :: grid_offset_type logical :: exchange_uv - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrsx=-9999, f_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrsx=c_null_ptr, f_addrsy=c_null_ptr logical :: do_update, is_complete integer, save :: isize(2)=0,jsize(2)=0,ke=0,l_size=0, offset_type=0, list=0 integer, save :: whalosz, ehalosz, shalosz, nhalosz @@ -340,8 +340,8 @@ call mpp_error(FATAL,'MPP_UPDATE_AD_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if(list == 1 .AND. tile == 1)then isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2); ke = size(fieldx,3) @@ -412,7 +412,7 @@ d_type,ke,grid_offset_type, flags) end if end if - l_size=0; f_addrsx=-9999; f_addrsy=-9999; isize=0; jsize=0; ke=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; isize=0; jsize=0; ke=0 end if return @@ -422,7 +422,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) !updates data domain of 4D ad field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -430,13 +430,11 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx(:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy(:,:,:,:) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) return @@ -445,7 +443,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) !updates data domain of 5D ad field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype logical, intent(in), optional :: complete @@ -453,12 +451,11 @@ character(len=*), intent(in), optional :: name integer, intent(in), optional :: tile_count - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) => fieldx(:,:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) => fieldy(:,:,:,:,:) + call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) diff --git a/mpp/include/mpp_update_domains2D_nonblock.fh b/mpp/include/mpp_update_domains2D_nonblock.fh index b1854a18c5..83403ac34b 100644 --- a/mpp/include/mpp_update_domains2D_nonblock.fh +++ b/mpp/include/mpp_update_domains2D_nonblock.fh @@ -20,7 +20,7 @@ function MPP_START_UPDATE_DOMAINS_2D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete) type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -30,9 +30,8 @@ function MPP_START_UPDATE_DOMAINS_2D_( field, domain, flags, position, & logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_2D_ - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) MPP_START_UPDATE_DOMAINS_2D_ = mpp_start_update_domains(field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete) @@ -42,9 +41,11 @@ end function MPP_START_UPDATE_DOMAINS_2D_ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc, c_associated type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: & + field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -64,7 +65,7 @@ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & integer, save :: pos, whalosz, ehalosz, shalosz, nhalosz, update_flags_saved character(len=128) :: text, field_name integer, save :: ke_list(MAX_DOMAIN_FIELDS, MAX_TILES)=0 - integer(i8_kind), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 + type(c_ptr), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr type(overlapSpec), pointer :: update => NULL() MPP_TYPE_ :: d_type @@ -138,14 +139,14 @@ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list,tile) = LOC(field) + f_addrs(list,tile) = c_loc(field) ke_list(list,tile) = size(field,3) !make sure the field is not called mpp_start_update_domains. Currently we only check the address at tile = 1. if( tile == 1 ) then do n = 1, current_id_update do l = 1, nonblock_data(n)%nfields - if( f_addrs(list,tile) == nonblock_data(n)%field_addrs(l)) then + if(c_associated(f_addrs(list,tile), nonblock_data(n)%field_addrs(l))) then call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_3D is called again before calling ' //& 'mpp_complte_UPDATE_DOMAINS_3D for field '//trim(field_name)) endif @@ -229,7 +230,7 @@ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & call mpp_start_do_update(current_id, f_addrs(1:l_size,1:ntile), domain, update, d_type, & ke_max, ke_list(1:l_size,1:ntile), update_flags, reuse_id_update, field_name ) endif - l_size=0; f_addrs=-9999; isize=0; jsize=0; ke_list=0 + l_size=0; f_addrs=c_null_ptr; isize=0; jsize=0; ke_list=0 else if(present(update_id)) then MPP_START_UPDATE_DOMAINS_3D_ = update_id @@ -245,7 +246,7 @@ end function MPP_START_UPDATE_DOMAINS_3D_ function MPP_START_UPDATE_DOMAINS_4D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -255,9 +256,8 @@ function MPP_START_UPDATE_DOMAINS_4D_( field, domain, flags, position, & logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_4D_ - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) MPP_START_UPDATE_DOMAINS_4D_ = mpp_start_update_domains(field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete) @@ -269,7 +269,7 @@ end function MPP_START_UPDATE_DOMAINS_4D_ function MPP_START_UPDATE_DOMAINS_5D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete) type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -279,9 +279,8 @@ function MPP_START_UPDATE_DOMAINS_5D_( field, domain, flags, position, & logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_5D_ - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)*size(field,5)) => field(:,:,:,:,:) MPP_START_UPDATE_DOMAINS_5D_ = mpp_start_update_domains(field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) @@ -294,7 +293,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_( id_update, field, domain, flags, pos whalo, ehalo, shalo, nhalo, name, tile_count, complete ) integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -302,9 +301,9 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_( id_update, field, domain, flags, pos integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) + call mpp_complete_update_domains(id_update, field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) @@ -313,9 +312,11 @@ end subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_ !################################################################################## subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc, c_associated integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: & + field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -333,7 +334,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, pos integer :: ke_max integer, save :: list=0, l_size=0 integer, save :: ke_list(MAX_DOMAIN_FIELDS, MAX_TILES)=0 - integer(i8_kind), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 + type(c_ptr), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr character(len=128) :: text MPP_TYPE_ :: d_type @@ -395,10 +396,10 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, pos write( text,'(i2)' ) MAX_DOMAIN_FIELDS call mpp_error(FATAL,'MPP_COMPLETE_UPDATE_DOMAINS_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list, tile) = LOC(field) + f_addrs(list, tile) = c_loc(field) !-- make sure the f_addrs match the one at mpp_start_update_domains if( tile == 1 ) then - if( nonblock_data(id_update)%field_addrs(list) .NE. f_addrs(list, tile)) then + if(.NOT. c_associated(nonblock_data(id_update)%field_addrs(list), f_addrs(list, tile))) then call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// & "mismatch of address between mpp_start_update_domains and mpp_complete_update_domains") endif @@ -444,8 +445,8 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, pos ke_max, ke_list(1:l_size,1:ntile), update_flags) endif nonblock_data(id_update)%nfields = 0 - nonblock_data(id_update)%field_addrs(1:l_size) = 0 - l_size=0; f_addrs=-9999; ke_list=0 + nonblock_data(id_update)%field_addrs(1:l_size) = c_null_ptr + l_size=0; f_addrs=c_null_ptr; ke_list=0 !--- For the last call of mpp_complete_update_domains !--- reset everything to init state if( num_update == 0) then @@ -464,7 +465,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_( id_update, field, domain, flags, pos whalo, ehalo, shalo, nhalo, name, tile_count, complete ) integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -472,9 +473,9 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_( id_update, field, domain, flags, pos integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) + call mpp_complete_update_domains(id_update, field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) @@ -485,7 +486,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_( id_update, field, domain, flags, pos whalo, ehalo, shalo, nhalo, name, tile_count, complete ) integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: field(:,:,:,:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -493,9 +494,9 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_( id_update, field, domain, flags, pos integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5)) - pointer( ptr, field3D ) - ptr = LOC(field) + MPP_TYPE_, pointer :: field3D(:,:,:) + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)*size(field,5)) => field(:,:,:,:,:) + call mpp_complete_update_domains(id_update, field3D, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) @@ -505,7 +506,7 @@ end subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_ function MPP_START_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) !updates data domain of 3D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -514,12 +515,11 @@ function MPP_START_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype integer, intent(in), optional :: update_id logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_2D_V_ - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx(:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy(:,:) MPP_START_UPDATE_DOMAINS_2D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) @@ -532,7 +532,8 @@ end function MPP_START_UPDATE_DOMAINS_2D_V_ function MPP_START_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) !updates data domain of 3D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc, c_associated + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -551,8 +552,8 @@ function MPP_START_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype integer, save :: whalosz, ehalosz, shalosz, nhalosz integer, save :: isize(2)=0,jsize(2)=0,l_size=0, offset_type=0, list=0 integer, save :: ke_list (MAX_DOMAIN_FIELDS, MAX_TILES)=0 - integer(i8_kind), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 - integer(i8_kind), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 + type(c_ptr), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr + type(c_ptr), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr type(overlapSpec), pointer :: updatex => NULL() type(overlapSpec), pointer :: updatey => NULL() MPP_TYPE_ :: d_type @@ -634,14 +635,15 @@ function MPP_START_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) if( tile == 1 ) then do n = 1, current_id_update do l = 1, nonblock_data(n)%nfields - if( f_addrsx(list,tile) == nonblock_data(n)%field_addrs(l) .OR. & - f_addrsy(list,tile) == nonblock_data(n)%field_addrs2(l)) then + if( .NOT. c_associated(f_addrsx(list,tile)) .OR. .NOT. c_associated(f_addrsy(list,tile)) .OR. & + c_associated(f_addrsx(list,tile), nonblock_data(n)%field_addrs(l)) .OR. & + c_associated(f_addrsy(list,tile), nonblock_data(n)%field_addrs2(l))) then call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V is called again before calling ' //& 'mpp_complte_UPDATE_DOMAINS_V for field '//trim(field_name)) endif @@ -757,7 +759,7 @@ function MPP_START_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype update_flags, reuse_id_update, field_name) endif endif - l_size=0; f_addrsx=-9999; f_addrsy=-9999; isize=0; jsize=0; ke_list=0 + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; isize=0; jsize=0; ke_list=0 else if(present(update_id)) then MPP_START_UPDATE_DOMAINS_3D_V_ = update_id @@ -773,7 +775,7 @@ end function MPP_START_UPDATE_DOMAINS_3D_V_ function MPP_START_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) !updates data domain of 3D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -782,12 +784,10 @@ function MPP_START_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype integer, intent(in), optional :: update_id logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_4D_V_ - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx(:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy(:,:,:,:) MPP_START_UPDATE_DOMAINS_4D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) @@ -799,7 +799,7 @@ end function MPP_START_UPDATE_DOMAINS_4D_V_ function MPP_START_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) !updates data domain of 3D field whose computational domains have been computed - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -808,12 +808,11 @@ function MPP_START_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype integer, intent(in), optional :: update_id logical, intent(in), optional :: complete integer :: MPP_START_UPDATE_DOMAINS_5D_V_ - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) => fieldx(:,:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)*size(fieldx,5)) => fieldy(:,:,:,:,:) MPP_START_UPDATE_DOMAINS_5D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) @@ -827,7 +826,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_V_( id_update, fieldx, fieldy, domain, whalo, ehalo, shalo, nhalo, name, tile_count, complete ) !updates data domain of 3D field whose computational domains have been computed integer, intent(in) :: id_update - MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -835,12 +834,10 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_V_( id_update, fieldx, fieldy, domain, integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx(:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy(:,:) call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) @@ -853,8 +850,9 @@ end subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_V_ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_( id_update, fieldx, fieldy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) !updates data domain of 3D field whose computational domains have been computed + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc, c_associated integer, intent(in) :: id_update - MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -870,8 +868,8 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_( id_update, fieldx, fieldy, domain, character(len=128) :: text integer, save :: l_size=0, list=0 integer, save :: ke_list (MAX_DOMAIN_FIELDS, MAX_TILES)=0 - integer(i8_kind), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 - integer(i8_kind), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999 + type(c_ptr), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr + type(c_ptr), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=c_null_ptr type(overlapSpec), pointer :: updatex => NULL() type(overlapSpec), pointer :: updatey => NULL() MPP_TYPE_ :: d_type @@ -966,12 +964,12 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_( id_update, fieldx, fieldy, domain, call mpp_error(FATAL,'MPP_UPDATE_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrsx(list, tile) = LOC(fieldx) - f_addrsy(list, tile) = LOC(fieldy) + f_addrsx(list, tile) = c_loc(fieldx) + f_addrsy(list, tile) = c_loc(fieldy) !-- make sure the f_addrs match the one at mpp_start_update_domains if( tile == 1 ) then - if( nonblock_data(id_update)%field_addrs(list) .NE. f_addrsx(list, tile) .OR. & - nonblock_data(id_update)%field_addrs2(list) .NE. f_addrsy(list, tile)) then + if( .NOT. c_associated(nonblock_data(id_update)%field_addrs(list), f_addrsx(list, tile)) .OR. & + .NOT. c_associated(nonblock_data(id_update)%field_addrs2(list), f_addrsy(list, tile))) then call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_V: "// & "mismatch of address between mpp_start_update_domains and mpp_complete_update_domains") endif @@ -1025,9 +1023,9 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_( id_update, fieldx, fieldy, domain, endif endif nonblock_data(id_update)%nfields = 0 - nonblock_data(id_update)%field_addrs(1:l_size) = 0 - nonblock_data(id_update)%field_addrs2(1:l_size) = 0 - l_size=0; f_addrsx=-9999; f_addrsy=-9999; ke_list=0 + nonblock_data(id_update)%field_addrs(1:l_size) = c_null_ptr + nonblock_data(id_update)%field_addrs2(1:l_size) = c_null_ptr + l_size=0; f_addrsx=c_null_ptr; f_addrsy=c_null_ptr; ke_list=0 !--- For the last call of mpp_complete_update_domains !--- reset everything to init state if( num_update == 0) then @@ -1047,7 +1045,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_V_( id_update, fieldx, fieldy, domain, whalo, ehalo, shalo, nhalo, name, tile_count, complete ) !updates data domain of 3D field whose computational domains have been computed integer, intent(in) :: id_update - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -1055,12 +1053,10 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_V_( id_update, fieldx, fieldy, domain, integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx(:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy(:,:,:,:) call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) @@ -1074,7 +1070,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_V_( id_update, fieldx, fieldy, domain, whalo, ehalo, shalo, nhalo, name, tile_count, complete ) !updates data domain of 3D field whose computational domains have been computed integer, intent(in) :: id_update - MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype integer, intent(in), optional :: whalo, ehalo, shalo, nhalo @@ -1082,12 +1078,10 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_V_( id_update, fieldx, fieldy, domain, integer, intent(in), optional :: tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)*size(fieldx,5)) => fieldx(:,:,:,:,:) + field3Dx(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)*size(fieldx,5)) => fieldy(:,:,:,:,:) call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, & whalo, ehalo, shalo, nhalo, name, tile_count, complete ) diff --git a/mpp/include/mpp_update_nest_domains.fh b/mpp/include/mpp_update_nest_domains.fh index 1c08ddcead..0b1d338849 100644 --- a/mpp/include/mpp_update_nest_domains.fh +++ b/mpp/include/mpp_update_nest_domains.fh @@ -20,17 +20,17 @@ !> @{ subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, & nest_level, flags, complete, position, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: field(:,:) !< field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: wbuffer(:,:) !< west side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebuffer(:,:) !< east side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbuffer(:,:) !< south side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbuffer(:,:) !< north side buffer to be filled - !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:) !< field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: wbuffer(:,:) !< west side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: ebuffer(:,:) !< east side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: sbuffer(:,:) !< south side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: nbuffer(:,:) !< north side buffer to be filled + !! with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. !! Default value is XUPDATE+YUPDATE. @@ -45,21 +45,18 @@ subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffe integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - MPP_TYPE_ :: wbuffer3D(size(wbuffer,1),size(wbuffer,2),1) - MPP_TYPE_ :: ebuffer3D(size(ebuffer,1),size(ebuffer,2),1) - MPP_TYPE_ :: sbuffer3D(size(sbuffer,1),size(sbuffer,2),1) - MPP_TYPE_ :: nbuffer3D(size(nbuffer,1),size(nbuffer,2),1) - pointer( ptr, field3D ) - pointer( ptr_w, wbuffer3D) - pointer( ptr_e, ebuffer3D) - pointer( ptr_s, sbuffer3D) - pointer( ptr_n, nbuffer3D) - ptr = LOC(field) - ptr_w = LOC(wbuffer) - ptr_e = LOC(ebuffer) - ptr_s = LOC(sbuffer) - ptr_n = LOC(nbuffer) + MPP_TYPE_, pointer :: field3D(:,:,:) + MPP_TYPE_, pointer :: wbuffer3D(:,:,:) + MPP_TYPE_, pointer :: ebuffer3D(:,:,:) + MPP_TYPE_, pointer :: sbuffer3D(:,:,:) + MPP_TYPE_, pointer :: nbuffer3D(:,:,:) + + field3D(1:size(field,1),1:size(field,2),1:1) => field(:,:) + wbuffer3D(1:size(wbuffer,1),1:size(wbuffer,2),1:1) => wbuffer(:,:) + ebuffer3D(1:size(ebuffer,1),1:size(ebuffer,2),1:1) => ebuffer(:,:) + sbuffer3D(1:size(sbuffer,1),1:size(sbuffer,2),1:1) => sbuffer(:,:) + nbuffer3D(1:size(nbuffer,1),1:size(nbuffer,2),1:1) => nbuffer(:,:) + call mpp_update_nest_fine( field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, & nest_level, flags, complete, position, extra_halo, name, tile_count) @@ -70,16 +67,17 @@ end subroutine MPP_UPDATE_NEST_FINE_2D_ subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, & nest_level, flags, complete, position, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: field(:,:,:) !< field on the model grid + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, intent(in) :: field(:,:,:) !< field on the model grid type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: wbuffer(:,:,:) !< west side buffer to be filled + MPP_TYPE_, target, intent(inout) :: wbuffer(:,:,:) !< west side buffer to be filled !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebuffer(:,:,:) !< east side buffer to be filled + MPP_TYPE_, target, intent(inout) :: ebuffer(:,:,:) !< east side buffer to be filled !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbuffer(:,:,:) !< south side buffer to be filled + MPP_TYPE_, target, intent(inout) :: sbuffer(:,:,:) !< south side buffer to be filled !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbuffer(:,:,:) !< north side buffer to be filled + MPP_TYPE_, target, intent(inout) :: nbuffer(:,:,:) !< north side buffer to be filled !! with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. @@ -97,11 +95,11 @@ subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffe MPP_TYPE_ :: d_type type(nestSpec), pointer :: update=>NULL() - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: f_addrs=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrs=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrs=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrs=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: f_addrs=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrs=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrs=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrs=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrs=c_null_ptr character(len=3) :: text logical :: is_complete, set_mismatch integer :: tile @@ -138,11 +136,11 @@ subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffe call mpp_error(FATAL,'MPP_UPDATE_NEST_FINE_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' ) endif - f_addrs(list) = LOC(field) - wb_addrs(list) = LOC(wbuffer) - eb_addrs(list) = LOC(ebuffer) - sb_addrs(list) = LOC(sbuffer) - nb_addrs(list) = LOC(nbuffer) + f_addrs(list) = c_loc(field) + wb_addrs(list) = c_loc(wbuffer) + eb_addrs(list) = c_loc(ebuffer) + sb_addrs(list) = c_loc(sbuffer) + nb_addrs(list) = c_loc(nbuffer) wbuffersz = size(wbuffer); ebuffersz = size(ebuffer) sbuffersz = size(sbuffer); nbuffersz = size(nbuffer) @@ -208,17 +206,17 @@ end subroutine MPP_UPDATE_NEST_FINE_3D_ !############################################################################### subroutine MPP_UPDATE_NEST_FINE_4D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, & nest_level, flags, complete, position, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: field(:,:,:,:) !< field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: wbuffer(:,:,:,:) !< west side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebuffer(:,:,:,:) !< east side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbuffer(:,:,:,:) !< south side buffer to be filled - !! with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbuffer(:,:,:,:) !< north side buffer to be filled - !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(in) :: field(:,:,:,:) !< field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: wbuffer(:,:,:,:) !< west side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: ebuffer(:,:,:,:) !< east side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: sbuffer(:,:,:,:) !< south side buffer to be filled + !! with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: nbuffer(:,:,:,:) !< north side buffer to be filled + !! with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. !! Default value is XUPDATE+YUPDATE. @@ -233,22 +231,18 @@ subroutine MPP_UPDATE_NEST_FINE_4D_(field, nest_domain, wbuffer, ebuffer, sbuffe integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)) - MPP_TYPE_ :: wbuffer3D(size(wbuffer,1),size(wbuffer,2),size(wbuffer,3)*size(wbuffer,4)) - MPP_TYPE_ :: ebuffer3D(size(ebuffer,1),size(ebuffer,2),size(ebuffer,3)*size(ebuffer,4)) - MPP_TYPE_ :: sbuffer3D(size(sbuffer,1),size(sbuffer,2),size(sbuffer,3)*size(sbuffer,4)) - MPP_TYPE_ :: nbuffer3D(size(nbuffer,1),size(nbuffer,2),size(nbuffer,3)*size(nbuffer,4)) - - pointer( ptr, field3D ) - pointer( ptr_w, wbuffer3D) - pointer( ptr_e, ebuffer3D) - pointer( ptr_s, sbuffer3D) - pointer( ptr_n, nbuffer3D) - ptr = LOC(field) - ptr_w = LOC(wbuffer) - ptr_e = LOC(ebuffer) - ptr_s = LOC(sbuffer) - ptr_n = LOC(nbuffer) + MPP_TYPE_, pointer :: field3D(:,:,:) + MPP_TYPE_, pointer :: wbuffer3D(:,:,:) + MPP_TYPE_, pointer :: ebuffer3D(:,:,:) + MPP_TYPE_, pointer :: sbuffer3D(:,:,:) + MPP_TYPE_, pointer :: nbuffer3D(:,:,:) + + field3D(1:size(field,1),1:size(field,2),1:size(field,3)*size(field,4)) => field(:,:,:,:) + wbuffer3D(1:size(wbuffer,1),1:size(wbuffer,2),1:size(wbuffer,3)*size(wbuffer,4)) => wbuffer(:,:,:,:) + ebuffer3D(1:size(ebuffer,1),1:size(ebuffer,2),1:size(ebuffer,3)*size(ebuffer,4)) => ebuffer(:,:,:,:) + sbuffer3D(1:size(sbuffer,1),1:size(sbuffer,2),1:size(sbuffer,3)*size(sbuffer,4)) => sbuffer(:,:,:,:) + nbuffer3D(1:size(nbuffer,1),1:size(nbuffer,2),1:size(nbuffer,3)*size(nbuffer,4)) => nbuffer(:,:,:,:) + call mpp_update_nest_fine( field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, & nest_level, flags, complete, position, extra_halo, name, tile_count) @@ -261,17 +255,18 @@ end subroutine MPP_UPDATE_NEST_FINE_4D_ subroutine MPP_UPDATE_NEST_FINE_2D_V_(fieldx, fieldy, nest_domain, wbufferx, wbuffery, sbufferx, sbuffery, & ebufferx, ebuffery, nbufferx, nbuffery, nest_level, & flags, gridtype, complete, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:) !< field x and y components on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: wbufferx(:,:), wbuffery(:,:) !< west side buffer x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebufferx(:,:), ebuffery(:,:) !< east side buffer x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbufferx(:,:), sbuffery(:,:) !< south side buffer x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbufferx(:,:), nbuffery(:,:) !< north side buffer x and y components - !! to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:), fieldy(:,:) !< field x and y components + !! on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: wbufferx(:,:), wbuffery(:,:) !< west side buffer x and y components + !! to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: ebufferx(:,:), ebuffery(:,:) !< east side buffer x and y components + !! to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: sbufferx(:,:), sbuffery(:,:) !< south side buffer x and y components + !! to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: nbufferx(:,:), nbuffery(:,:) !< north side buffer x and y components + !! to be filled with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. !! Default value is XUPDATE+YUPDATE. @@ -285,37 +280,27 @@ subroutine MPP_UPDATE_NEST_FINE_2D_V_(fieldx, fieldy, nest_domain, wbufferx, wbu integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1) - MPP_TYPE_ :: wbuffer3Dx(size(wbufferx,1),size(wbufferx,2),1) - MPP_TYPE_ :: ebuffer3Dx(size(ebufferx,1),size(ebufferx,2),1) - MPP_TYPE_ :: sbuffer3Dx(size(sbufferx,1),size(sbufferx,2),1) - MPP_TYPE_ :: nbuffer3Dx(size(nbufferx,1),size(nbufferx,2),1) - MPP_TYPE_ :: wbuffer3Dy(size(wbuffery,1),size(wbuffery,2),1) - MPP_TYPE_ :: ebuffer3Dy(size(ebuffery,1),size(ebuffery,2),1) - MPP_TYPE_ :: sbuffer3Dy(size(sbuffery,1),size(sbuffery,2),1) - MPP_TYPE_ :: nbuffer3Dy(size(nbuffery,1),size(nbuffery,2),1) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - pointer( ptr_wx, wbuffer3Dx) - pointer( ptr_ex, ebuffer3Dx) - pointer( ptr_sx, sbuffer3Dx) - pointer( ptr_nx, nbuffer3Dx) - pointer( ptr_wy, wbuffer3Dy) - pointer( ptr_ey, ebuffer3Dy) - pointer( ptr_sy, sbuffer3Dy) - pointer( ptr_ny, nbuffer3Dy) - - ptrx = LOC(fieldx) - ptry = LOC(fieldy) - ptr_wx = LOC(wbufferx) - ptr_ex = LOC(ebufferx) - ptr_sx = LOC(sbufferx) - ptr_nx = LOC(nbufferx) - ptr_wy = LOC(wbuffery) - ptr_ey = LOC(ebuffery) - ptr_sy = LOC(sbuffery) - ptr_ny = LOC(nbuffery) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + MPP_TYPE_, pointer :: wbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: ebuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: sbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: nbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: wbuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: ebuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: sbuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: nbuffer3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:1) => fieldx(:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:1) => fieldy(:,:) + wbuffer3Dx(1:size(wbufferx,1),1:size(wbufferx,2),1:1) => wbufferx(:,:) + ebuffer3Dx(1:size(ebufferx,1),1:size(ebufferx,2),1:1) => ebufferx(:,:) + sbuffer3Dx(1:size(sbufferx,1),1:size(sbufferx,2),1:1) => sbufferx(:,:) + nbuffer3Dx(1:size(nbufferx,1),1:size(nbufferx,2),1:1) => nbufferx(:,:) + wbuffer3Dy(1:size(wbuffery,1),1:size(wbuffery,2),1:1) => wbuffery(:,:) + ebuffer3Dy(1:size(ebuffery,1),1:size(ebuffery,2),1:1) => ebuffery(:,:) + sbuffer3Dy(1:size(sbuffery,1),1:size(sbuffery,2),1:1) => sbuffery(:,:) + nbuffer3Dy(1:size(nbuffery,1),1:size(nbuffery,2),1:1) => nbuffery(:,:) call MPP_UPDATE_NEST_FINE_3D_V_(field3Dx, field3Dy, nest_domain, wbuffer3Dx, wbuffer3Dy, sbuffer3Dx, sbuffer3Dy, & ebuffer3Dx, ebuffer3Dy, nbuffer3Dx, nbuffer3Dy, nest_level, & @@ -326,17 +311,18 @@ end subroutine MPP_UPDATE_NEST_FINE_2D_V_ subroutine MPP_UPDATE_NEST_FINE_3D_V_(fieldx, fieldy, nest_domain, wbufferx, wbuffery, sbufferx, sbuffery, & ebufferx, ebuffery, nbufferx, nbuffery, nest_level, & flags, gridtype, complete, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx(:,:,:), fieldy(:,:,:) !< field x and y components + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, intent(in) :: fieldx(:,:,:), fieldy(:,:,:) !< field x and y components !! on the model grid type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: wbufferx(:,:,:), wbuffery(:,:,:) !< west side buffer x and y components + MPP_TYPE_, target, intent(inout) :: wbufferx(:,:,:), wbuffery(:,:,:) !< west side buffer x and y components !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebufferx(:,:,:), ebuffery(:,:,:) !< east side buffer x and y components + MPP_TYPE_, target, intent(inout) :: ebufferx(:,:,:), ebuffery(:,:,:) !< east side buffer x and y components !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbufferx(:,:,:), sbuffery(:,:,:) !< south side buffer x and y components + MPP_TYPE_, target, intent(inout) :: sbufferx(:,:,:), sbuffery(:,:,:) !< south side buffer x and y components !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbufferx(:,:,:), nbuffery(:,:,:) !< north side buffer x and y components + MPP_TYPE_, target, intent(inout) :: nbufferx(:,:,:), nbuffery(:,:,:) !< north side buffer x and y components !! to be filled with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. @@ -354,16 +340,16 @@ subroutine MPP_UPDATE_NEST_FINE_3D_V_(fieldx, fieldy, nest_domain, wbufferx, wbu MPP_TYPE_ :: d_type type(nestSpec), pointer :: updatex=>NULL() type(nestSpec), pointer :: updatey=>NULL() - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: f_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: f_addrsy=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrsy=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrsy=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrsy=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: f_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: f_addrsy=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: wb_addrsy=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: eb_addrsy=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: sb_addrsy=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: nb_addrsy=c_null_ptr character(len=3) :: text logical :: is_complete, set_mismatch @@ -426,8 +412,8 @@ subroutine MPP_UPDATE_NEST_FINE_3D_V_(fieldx, fieldy, nest_domain, wbufferx, wbu ksize = size(fieldx,3) if(nest_domain%nest(nest_level)%is_coarse_pe) then - f_addrsx(list) = LOC(fieldx) - f_addrsy(list) = LOC(fieldy) + f_addrsx(list) = c_loc(fieldx) + f_addrsy(list) = c_loc(fieldy) isizex=size(fieldx,1); jsizex=size(fieldx,2) isizey=size(fieldy,1); jsizey=size(fieldy,2) if(size(fieldx,3) .NE. size(fieldy,3)) call mpp_error(FATAL, & @@ -435,14 +421,14 @@ subroutine MPP_UPDATE_NEST_FINE_3D_V_(fieldx, fieldy, nest_domain, wbufferx, wbu endif if(nest_domain%nest(nest_level)%is_fine_pe) then - wb_addrsx(list) = LOC(wbufferx) - eb_addrsx(list) = LOC(ebufferx) - sb_addrsx(list) = LOC(sbufferx) - nb_addrsx(list) = LOC(nbufferx) - wb_addrsy(list) = LOC(wbuffery) - eb_addrsy(list) = LOC(ebuffery) - sb_addrsy(list) = LOC(sbuffery) - nb_addrsy(list) = LOC(nbuffery) + wb_addrsx(list) = c_loc(wbufferx) + eb_addrsx(list) = c_loc(ebufferx) + sb_addrsx(list) = c_loc(sbufferx) + nb_addrsx(list) = c_loc(nbufferx) + wb_addrsy(list) = c_loc(wbuffery) + eb_addrsy(list) = c_loc(ebuffery) + sb_addrsy(list) = c_loc(sbuffery) + nb_addrsy(list) = c_loc(nbuffery) wbufferszx = size(wbufferx); ebufferszx = size(ebufferx) sbufferszx = size(sbufferx); nbufferszx = size(nbufferx) @@ -555,21 +541,17 @@ end subroutine MPP_UPDATE_NEST_FINE_3D_V_ subroutine MPP_UPDATE_NEST_FINE_4D_V_(fieldx, fieldy, nest_domain, wbufferx, wbuffery, sbufferx, sbuffery, & ebufferx, ebuffery, nbufferx, nbuffery, nest_level, & flags, gridtype, complete, extra_halo, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx(:,:,:,:), fieldy(:,:,:,:) !< field x and y + MPP_TYPE_, target, contiguous, intent(in) :: fieldx(:,:,:,:), fieldy(:,:,:,:) !< field x and y !! components on the model grid - type(nest_domain_type), intent(inout) :: nest_domain - MPP_TYPE_, intent(inout) :: wbufferx(:,:,:,:), wbuffery(:,:,:,:) !< west side buffer - !! x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: ebufferx(:,:,:,:), ebuffery(:,:,:,:) !< east side buffer - !! x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: sbufferx(:,:,:,:), sbuffery(:,:,:,:) !< south side buffer - !! x and y components - !! to be filled with data on coarse grid. - MPP_TYPE_, intent(inout) :: nbufferx(:,:,:,:), nbuffery(:,:,:,:) !< north side buffer - !! x and y components - !! to be filled with data on coarse grid. + type(nest_domain_type), intent(inout) :: nest_domain + MPP_TYPE_, target, contiguous, intent(inout) :: wbufferx(:,:,:,:), wbuffery(:,:,:,:) !< west side buffer + !! x and y components to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: ebufferx(:,:,:,:), ebuffery(:,:,:,:) !< east side buffer + !! x and y components to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: sbufferx(:,:,:,:), sbuffery(:,:,:,:) !< south side buffer + !! x and y components to be filled with data on coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: nbufferx(:,:,:,:), nbuffery(:,:,:,:) !< north side buffer + !! x and y components to be filled with data on coarse grid. integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) integer, intent(in), optional :: flags !< Specify the direction of fine grid halo buffer to be filled. !! Default value is XUPDATE+YUPDATE. @@ -583,36 +565,27 @@ subroutine MPP_UPDATE_NEST_FINE_4D_V_(fieldx, fieldy, nest_domain, wbufferx, wbu integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)) - MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)) - MPP_TYPE_ :: wbuffer3Dx(size(wbufferx,1),size(wbufferx,2),size(wbufferx,3)*size(wbufferx,4)) - MPP_TYPE_ :: ebuffer3Dx(size(ebufferx,1),size(ebufferx,2),size(ebufferx,3)*size(ebufferx,4)) - MPP_TYPE_ :: sbuffer3Dx(size(sbufferx,1),size(sbufferx,2),size(sbufferx,3)*size(sbufferx,4)) - MPP_TYPE_ :: nbuffer3Dx(size(nbufferx,1),size(nbufferx,2),size(nbufferx,3)*size(nbufferx,4)) - MPP_TYPE_ :: wbuffer3Dy(size(wbuffery,1),size(wbuffery,2),size(wbuffery,3)*size(wbuffery,4)) - MPP_TYPE_ :: ebuffer3Dy(size(ebuffery,1),size(ebuffery,2),size(ebuffery,3)*size(ebuffery,4)) - MPP_TYPE_ :: sbuffer3Dy(size(sbuffery,1),size(sbuffery,2),size(sbuffery,3)*size(sbuffery,4)) - MPP_TYPE_ :: nbuffer3Dy(size(nbuffery,1),size(nbuffery,2),size(nbuffery,3)*size(nbuffery,4)) - pointer( ptrx, field3Dx ) - pointer( ptry, field3Dy ) - pointer( ptr_wx, wbuffer3Dx) - pointer( ptr_ex, ebuffer3Dx) - pointer( ptr_sx, sbuffer3Dx) - pointer( ptr_nx, nbuffer3Dx) - pointer( ptr_wy, wbuffer3Dy) - pointer( ptr_ey, ebuffer3Dy) - pointer( ptr_sy, sbuffer3Dy) - pointer( ptr_ny, nbuffer3Dy) - ptrx = LOC(fieldx) - ptry = LOC(fieldy) - ptr_wx = LOC(wbufferx) - ptr_ex = LOC(ebufferx) - ptr_sx = LOC(sbufferx) - ptr_nx = LOC(nbufferx) - ptr_wy = LOC(wbuffery) - ptr_ey = LOC(ebuffery) - ptr_sy = LOC(sbuffery) - ptr_ny = LOC(nbuffery) + MPP_TYPE_, pointer :: field3Dx(:,:,:) + MPP_TYPE_, pointer :: field3Dy(:,:,:) + MPP_TYPE_, pointer :: wbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: ebuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: sbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: nbuffer3Dx(:,:,:) + MPP_TYPE_, pointer :: wbuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: ebuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: sbuffer3Dy(:,:,:) + MPP_TYPE_, pointer :: nbuffer3Dy(:,:,:) + + field3Dx(1:size(fieldx,1),1:size(fieldx,2),1:size(fieldx,3)*size(fieldx,4)) => fieldx(:,:,:,:) + field3Dy(1:size(fieldy,1),1:size(fieldy,2),1:size(fieldy,3)*size(fieldy,4)) => fieldy(:,:,:,:) + wbuffer3Dx(1:size(wbufferx,1),1:size(wbufferx,2),1:size(wbufferx,3)*size(wbufferx,4)) => wbufferx(:,:,:,:) + ebuffer3Dx(1:size(ebufferx,1),1:size(ebufferx,2),1:size(ebufferx,3)*size(ebufferx,4)) => ebufferx(:,:,:,:) + sbuffer3Dx(1:size(sbufferx,1),1:size(sbufferx,2),1:size(sbufferx,3)*size(sbufferx,4)) => sbufferx(:,:,:,:) + nbuffer3Dx(1:size(nbufferx,1),1:size(nbufferx,2),1:size(nbufferx,3)*size(nbufferx,4)) => nbufferx(:,:,:,:) + wbuffer3Dy(1:size(wbuffery,1),1:size(wbuffery,2),1:size(wbuffery,3)*size(wbuffery,4)) => wbuffery(:,:,:,:) + ebuffer3Dy(1:size(ebuffery,1),1:size(ebuffery,2),1:size(ebuffery,3)*size(ebuffery,4)) => ebuffery(:,:,:,:) + sbuffer3Dy(1:size(sbuffery,1),1:size(sbuffery,2),1:size(sbuffery,3)*size(sbuffery,4)) => sbuffery(:,:,:,:) + nbuffer3Dy(1:size(nbuffery,1),1:size(nbuffery,2),1:size(nbuffery,3)*size(nbuffery,4)) => nbuffery(:,:,:,:) call MPP_UPDATE_NEST_FINE_3D_V_(field3Dx, field3Dy, nest_domain, wbuffer3Dx, wbuffer3Dy, sbuffer3Dx, sbuffer3Dy, & ebuffer3Dx, ebuffer3Dy, nbuffer3Dx, nbuffer3Dy, nest_level, & @@ -624,10 +597,10 @@ end subroutine MPP_UPDATE_NEST_FINE_4D_V_ subroutine MPP_UPDATE_NEST_COARSE_2D_(field_in, nest_domain, field_out, nest_level, complete, position, name, & & tile_count) - MPP_TYPE_, intent(in) :: field_in(:,:) !< field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: field_out(:,:) !< field_out to be filled with data on coarse grid + MPP_TYPE_, target, contiguous, intent(in) :: field_in(:,:) !< field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: field_out(:,:) !< field_out to be filled with data on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. !! Default value is .true. @@ -637,12 +610,12 @@ subroutine MPP_UPDATE_NEST_COARSE_2D_(field_in, nest_domain, field_out, nest_lev integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3D_in(size(field_in,1),size(field_in,2),1) - MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),1) - pointer( ptr_in, field3D_in ) - pointer( ptr_out, field3D_out) - ptr_in = LOC(field_in) - ptr_out = LOC(field_out) + MPP_TYPE_, pointer :: field3D_in(:,:,:) + MPP_TYPE_, pointer :: field3D_out(:,:,:) + + field3D_in(1:size(field_in,1),1:size(field_in,2),1:1) => field_in(:,:) + field3D_out(1:size(field_out,1),1:size(field_out,2),1:1) => field_out(:,:) + call mpp_update_nest_coarse( field3D_in, nest_domain, field3D_out, nest_level, complete, position, name, & & tile_count) @@ -656,10 +629,11 @@ end subroutine MPP_UPDATE_NEST_COARSE_2D_ !--- field_in and field_out are all on the coarse grid. field_in is remapped from fine grid to coarse grid. subroutine MPP_UPDATE_NEST_COARSE_3D_(field_in, nest_domain, field_out, nest_level, complete, position, name, & & tile_count) - MPP_TYPE_, intent(in) :: field_in(:,:,:) !< field on the model grid + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, intent(in) :: field_in(:,:,:) !< field on the model grid type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: field_out(:,:,:) !< field_out to be filled with data on coarse grid + MPP_TYPE_, target, intent(inout) :: field_out(:,:,:) !< field_out to be filled with data on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. Default value is .true. integer, intent(in), optional :: position !< Cell position. Its value should be CENTER, EAST, CORNER, @@ -670,8 +644,8 @@ subroutine MPP_UPDATE_NEST_COARSE_3D_(field_in, nest_domain, field_out, nest_lev MPP_TYPE_ :: d_type type(nestSpec), pointer :: update=>NULL() - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrs=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrs=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrs=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrs=c_null_ptr character(len=3) :: text logical :: is_complete, set_mismatch integer :: tile @@ -706,12 +680,12 @@ subroutine MPP_UPDATE_NEST_COARSE_3D_(field_in, nest_domain, field_out, nest_lev isize_out = 0; jsize_out = 0 if(nest_domain%nest(nest_level)%is_fine_pe) then - fin_addrs(list) = LOC(field_in) + fin_addrs(list) = c_loc(field_in) isize_in=size(field_in,1); jsize_in=size(field_in,2) ksize = size(field_in,3) endif if(nest_domain%nest(nest_level)%is_coarse_pe) then - fout_addrs(list) = LOC(field_out) + fout_addrs(list) = c_loc(field_out) isize_out=size(field_out,1); jsize_out=size(field_out,2) ksize = size(field_out,3) endif @@ -765,10 +739,11 @@ end subroutine MPP_UPDATE_NEST_COARSE_3D_ !############################################################################### subroutine MPP_UPDATE_NEST_COARSE_4D_(field_in, nest_domain, field_out, nest_level, complete, position, name, & & tile_count) - MPP_TYPE_, intent(in) :: field_in(:,:,:,:) !< field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. - MPP_TYPE_, intent(inout) :: field_out(:,:,:,:) !< field_out to be filled with data on coarse grid + MPP_TYPE_, target, contiguous, intent(in) :: field_in(:,:,:,:) !< field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(inout) :: field_out(:,:,:,:) !< field_out to be filled with data + !! on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. Default value is .true. integer, intent(in), optional :: position !< Cell position. Its value should be CENTER, EAST, CORNER, @@ -777,12 +752,12 @@ subroutine MPP_UPDATE_NEST_COARSE_4D_(field_in, nest_domain, field_out, nest_lev integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3D_in(size(field_in,1),size(field_in,2),size(field_in,3)*size(field_in,4)) - MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4)) - pointer( ptr_in, field3D_in ) - pointer( ptr_out, field3D_out ) - ptr_in = LOC(field_in) - ptr_out = LOC(field_out) + MPP_TYPE_, pointer :: field3D_in(:,:,:) + MPP_TYPE_, pointer :: field3D_out(:,:,:) + + field3D_in(1:size(field_in,1),1:size(field_in,2),1:size(field_in,3)*size(field_in,4)) => field_in(:,:,:,:) + field3D_out(1:size(field_out,1),1:size(field_out,2),1:size(field_out,3)*size(field_out,4)) => field_out(:,:,:,:) + call mpp_update_nest_coarse( field3D_in, nest_domain, field3D_out, nest_level, complete, position, name, & & tile_count) @@ -797,36 +772,32 @@ end subroutine MPP_UPDATE_NEST_COARSE_4D_ !--- field_in and field_out are all on the coarse grid. field_in is remapped from fine grid to coarse grid. subroutine MPP_UPDATE_NEST_COARSE_2D_V_(fieldx_in, fieldy_in, nest_domain, fieldx_out, fieldy_out, nest_level, & flags, gridtype, complete, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx_in(:,:) !< x component of field on the model grid - MPP_TYPE_, intent(in) :: fieldy_in(:,:) !< y component of field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(in) :: fieldx_in(:,:) !< x component of field on the model grid + MPP_TYPE_, target, contiguous, intent(in) :: fieldy_in(:,:) !< y component of field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. integer, intent(in), optional :: flags, gridtype !< Specify the direction of fine grid halo !! buffer to be filled. - !! Default value is XUPDATE+YUPDATE. - MPP_TYPE_, intent(inout) :: fieldx_out(:,:) !< x component of field_out to be - !! filled with data on coarse grid - MPP_TYPE_, intent(inout) :: fieldy_out(:,:) !< y component of field_out to be - !! filled with data on coarse grid + !! Default value is XUPDATE+YUPDATE. + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx_out(:,:) !< x component of field_out to be + !! filled with data on coarse grid + MPP_TYPE_, target, contiguous, intent(inout) :: fieldy_out(:,:) !< y component of field_out to be + !! filled with data on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. character(len=*), intent(in), optional :: name !< Name of the nest domain optional argument integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3Dx_in(size(fieldx_in,1),size(fieldx_in,2),1) - MPP_TYPE_ :: field3Dy_in(size(fieldy_in,1),size(fieldy_in,2),1) - MPP_TYPE_ :: field3Dx_out(size(fieldx_out,1),size(fieldx_out,2),1) - MPP_TYPE_ :: field3Dy_out(size(fieldy_out,1),size(fieldy_out,2),1) - pointer( ptrx_in, field3Dx_in ) - pointer( ptry_in, field3Dy_in ) - pointer( ptrx_out, field3Dx_out ) - pointer( ptry_out, field3Dy_out ) + MPP_TYPE_, pointer :: field3Dx_in(:,:,:) + MPP_TYPE_, pointer :: field3Dy_in(:,:,:) + MPP_TYPE_, pointer :: field3Dx_out(:,:,:) + MPP_TYPE_, pointer :: field3Dy_out(:,:,:) - ptrx_in = LOC(fieldx_in) - ptry_in = LOC(fieldy_in) - ptrx_out = LOC(fieldx_out) - ptry_out = LOC(fieldy_out) + field3Dx_in(1:size(fieldx_in,1),1:size(fieldx_in,2),1:1) => fieldx_in(:,:) + field3Dy_in(1:size(fieldy_in,1),1:size(fieldy_in,2),1:1) => fieldy_in(:,:) + field3Dx_out(1:size(fieldx_out,1),1:size(fieldx_out,2),1:1) => fieldx_out(:,:) + field3Dy_out(1:size(fieldy_out,1),1:size(fieldy_out,2),1:1) => fieldy_out(:,:) call MPP_UPDATE_NEST_COARSE_3D_V_(field3Dx_in, field3Dy_in, nest_domain, field3Dx_out, field3Dy_out, & nest_level, flags, gridtype, complete, name, tile_count) @@ -838,16 +809,17 @@ end subroutine MPP_UPDATE_NEST_COARSE_2D_V_ !--- field_in and field_out are all on the coarse grid. field_in is remapped from fine grid to coarse grid. subroutine MPP_UPDATE_NEST_COARSE_3D_V_(fieldx_in, fieldy_in, nest_domain, fieldx_out, fieldy_out, nest_level, & flags, gridtype, complete, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx_in(:,:,:) !< x component field on the model grid - MPP_TYPE_, intent(in) :: fieldy_in(:,:,:) !< y component of field on the model grid + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr, c_loc + MPP_TYPE_, target, intent(in) :: fieldx_in(:,:,:) !< x component field on the model grid + MPP_TYPE_, target, intent(in) :: fieldy_in(:,:,:) !< y component of field on the model grid type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data !! between fine and coarse grid. integer, intent(in), optional :: flags, gridtype !< Specify the direction of fine grid halo !! buffer to be filled. !! Default value is XUPDATE+YUPDATE. - MPP_TYPE_, intent(inout) :: fieldx_out(:,:,:) !< x component of field_out to be + MPP_TYPE_, target, intent(inout) :: fieldx_out(:,:,:) !< x component of field_out to be !! filled with data on coarse grid - MPP_TYPE_, intent(inout) :: fieldy_out(:,:,:) !< y component of field_out to be + MPP_TYPE_, target, intent(inout) :: fieldy_out(:,:,:) !< y component of field_out to be !! filled with data on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. @@ -858,10 +830,10 @@ subroutine MPP_UPDATE_NEST_COARSE_3D_V_(fieldx_in, fieldy_in, nest_domain, field MPP_TYPE_ :: d_type type(nestSpec), pointer :: updatex=>NULL() type(nestSpec), pointer :: updatey=>NULL() - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrsy=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrsx=-9999 - integer(i8_kind),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrsy=-9999 + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fin_addrsy=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrsx=c_null_ptr + type(c_ptr),dimension(MAX_DOMAIN_FIELDS),save :: fout_addrsy=c_null_ptr character(len=3) :: text logical :: is_complete, set_mismatch integer :: tile @@ -917,8 +889,8 @@ subroutine MPP_UPDATE_NEST_COARSE_3D_V_(fieldx_in, fieldy_in, nest_domain, field ksize = 0 if(nest_domain%nest(nest_level)%is_fine_pe) then - fin_addrsx(list) = LOC(fieldx_in) - fin_addrsy(list) = LOC(fieldy_in) + fin_addrsx(list) = c_loc(fieldx_in) + fin_addrsy(list) = c_loc(fieldy_in) isizex_in=size(fieldx_in,1); jsizex_in=size(fieldx_in,2) isizey_in=size(fieldy_in,1); jsizey_in=size(fieldy_in,2) ksize = size(fieldx_in,3) @@ -926,8 +898,8 @@ subroutine MPP_UPDATE_NEST_COARSE_3D_V_(fieldx_in, fieldy_in, nest_domain, field 'MPP_UPDATE_NEST_COARSE_3D_V: size(fieldx_in,3) .NE. size(fieldy_in,3)') endif if(nest_domain%nest(nest_level)%is_coarse_pe) then - fout_addrsx(list) = LOC(fieldx_out) - fout_addrsy(list) = LOC(fieldy_out) + fout_addrsx(list) = c_loc(fieldx_out) + fout_addrsy(list) = c_loc(fieldy_out) isizex_out=size(fieldx_out,1); jsizex_out=size(fieldx_out,2) isizey_out=size(fieldy_out,1); jsizey_out=size(fieldy_out,2) ksize = size(fieldx_out,3) @@ -1023,36 +995,34 @@ end subroutine MPP_UPDATE_NEST_COARSE_3D_V_ subroutine MPP_UPDATE_NEST_COARSE_4D_V_(fieldx_in, fieldy_in, nest_domain, fieldx_out, fieldy_out, nest_level, & flags, gridtype, complete, name, tile_count) - MPP_TYPE_, intent(in) :: fieldx_in(:,:,:,:) !< x component field on the model grid - MPP_TYPE_, intent(in) :: fieldy_in(:,:,:,:) !< y component field on the model grid - type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data - !! between fine and coarse grid. + MPP_TYPE_, target, contiguous, intent(in) :: fieldx_in(:,:,:,:) !< x component field on the model grid + MPP_TYPE_, target, contiguous, intent(in) :: fieldy_in(:,:,:,:) !< y component field on the model grid + type(nest_domain_type), intent(inout) :: nest_domain !< Holds the information to pass data + !! between fine and coarse grid. integer, intent(in), optional :: flags, gridtype !< Specify the direction of fine grid halo !! buffer to be filled. !! Default value is XUPDATE+YUPDATE. - MPP_TYPE_, intent(inout) :: fieldx_out(:,:,:,:) !< x component of field_out to be - !! filled with data on coarse grid - MPP_TYPE_, intent(inout) :: fieldy_out(:,:,:,:) !< y component of field_out to be - !! filled with data on coarse grid + MPP_TYPE_, target, contiguous, intent(inout) :: fieldx_out(:,:,:,:) !< x component of field_out to be + !! filled with data on coarse grid + MPP_TYPE_, target, contiguous, intent(inout) :: fieldy_out(:,:,:,:) !< y component of field_out to be + !! filled with data on coarse grid integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest) logical, intent(in), optional :: complete !< When .true., do the buffer filling. character(len=*), intent(in), optional :: name !< Name of the nest domain optional argument integer, intent(in), optional :: tile_count !< Used to support multiple-tile-per-pe. !! default is 1 and currently only support tile_count = 1. - MPP_TYPE_ :: field3Dx_in(size(fieldx_in,1),size(fieldx_in,2),size(fieldx_in,3)*size(fieldx_in,4)) - MPP_TYPE_ :: field3Dy_in(size(fieldy_in,1),size(fieldy_in,2),size(fieldy_in,3)*size(fieldy_in,4)) - MPP_TYPE_ :: field3Dx_out(size(fieldx_out,1),size(fieldx_out,2),size(fieldx_out,3)*size(fieldx_out,4)) - MPP_TYPE_ :: field3Dy_out(size(fieldy_out,1),size(fieldy_out,2),size(fieldy_out,3)*size(fieldy_out,4)) - pointer( ptrx_in, field3Dx_in ) - pointer( ptry_in, field3Dy_in ) - pointer( ptrx_out, field3Dx_out ) - pointer( ptry_out, field3Dy_out ) - - ptrx_in = LOC(fieldx_in) - ptry_in = LOC(fieldy_in) - ptrx_out = LOC(fieldx_out) - ptry_out = LOC(fieldy_out) + MPP_TYPE_, pointer :: field3Dx_in(:,:,:) + MPP_TYPE_, pointer :: field3Dy_in(:,:,:) + MPP_TYPE_, pointer :: field3Dx_out(:,:,:) + MPP_TYPE_, pointer :: field3Dy_out(:,:,:) + + field3Dx_in(1:size(fieldx_in,1),1:size(fieldx_in,2),1:size(fieldx_in,3)*size(fieldx_in,4)) => fieldx_in(:,:,:,:) + field3Dy_in(1:size(fieldy_in,1),1:size(fieldy_in,2),1:size(fieldy_in,3)*size(fieldy_in,4)) => fieldy_in(:,:,:,:) + field3Dx_out(1:size(fieldx_out,1),1:size(fieldx_out,2),1:size(fieldx_out,3)*size(fieldx_out,4)) => & + fieldx_out(:,:,:,:) + field3Dy_out(1:size(fieldy_out,1),1:size(fieldy_out,2),1:size(fieldy_out,3)*size(fieldy_out,4)) => & + fieldy_out(:,:,:,:) call MPP_UPDATE_NEST_COARSE_3D_V_(field3Dx_in, field3Dy_in, nest_domain, field3Dx_out, field3Dy_out, & nest_level, flags, gridtype, complete, name, tile_count) diff --git a/mpp/mpp.F90 b/mpp/mpp.F90 index b10de61c46..ff4536c648 100644 --- a/mpp/mpp.F90 +++ b/mpp/mpp.F90 @@ -209,6 +209,7 @@ module mpp_mod public :: read_ascii_file, read_input_nml, mpp_clock_begin, mpp_clock_end public :: get_ascii_file_num_lines, get_ascii_file_num_lines_and_length public :: mpp_record_time_start, mpp_record_time_end + public :: get_pointer_address !--- public interface from mpp_comm.h ------------------------------ public :: mpp_chksum, mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv @@ -1383,6 +1384,20 @@ module mpp_mod #include #include + !> @brief converts c_ptr to integer address for pointer arithmetics + !! + !! hack of Fortran language for getting integer representation of c_ptr + !! + !> @param[in] pointer pointer which address should be presented as integer + !> @return integer representation of pointer's address + !> @author Igor S. Gerasimov (foxtranigor@gmail.com) + pure function get_pointer_address(pointer) result(address) + use, intrinsic :: iso_c_binding, only: c_ptr, c_intptr_t + type(c_ptr), intent(in) :: pointer + integer(c_intptr_t) :: address + address = transfer(pointer, address) + end function get_pointer_address + end module mpp_mod !> @} ! close documentation grouping diff --git a/mpp/mpp_data.F90 b/mpp/mpp_data.F90 index 1536da2dbd..c6c56ba342 100644 --- a/mpp/mpp_data.F90 +++ b/mpp/mpp_data.F90 @@ -31,6 +31,7 @@ module mpp_data_mod use mpi #endif + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr use mpp_parameter_mod, only : MAXPES use platform_mod @@ -47,8 +48,8 @@ module mpp_data_mod !--- All othere modules should import these parameters from mpp_domains_mod. !> public data which is used by mpp_domains_mod. - public :: mpp_domains_stack, ptr_domains_stack - public :: mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + public :: mpp_domains_stack, ptr_domains_stakc + public :: mpp_domains_stack_nonblock, ptr_domains_stakc_nonblock !-------------------------------------------------------------------------------! ! The following data included in the .inc file are diffrent for sma or mpi case ! diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index 5579605482..4c73b84daf 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -94,6 +94,8 @@ module mpp_domains_mod use mpi #endif + use, intrinsic :: iso_c_binding, only : c_ptr, c_null_ptr + use mpp_parameter_mod, only : MPP_DEBUG, MPP_VERBOSE, MPP_DOMAIN_TIME use mpp_parameter_mod, only : GLOBAL_DATA_DOMAIN, CYCLIC_GLOBAL_DOMAIN, GLOBAL,CYCLIC use mpp_parameter_mod, only : AGRID, BGRID_SW, BGRID_NE, CGRID_NE, CGRID_SW, DGRID_NE, DGRID_SW @@ -108,8 +110,8 @@ module mpp_domains_mod use mpp_parameter_mod, only : EVENT_SEND, EVENT_RECV, ROOT_GLOBAL use mpp_parameter_mod, only : NONBLOCK_UPDATE_TAG, EDGEONLY, EDGEUPDATE use mpp_parameter_mod, only : NONSYMEDGE, NONSYMEDGEUPDATE - use mpp_data_mod, only : mpp_domains_stack, ptr_domains_stack - use mpp_data_mod, only : mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + use mpp_data_mod, only : mpp_domains_stack, ptr_domains_stakc + use mpp_data_mod, only : mpp_domains_stack_nonblock, ptr_domains_stakc_nonblock use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_error, FATAL, WARNING, NOTE use mpp_mod, only : stdout, stderr, stdlog, mpp_send, mpp_recv, mpp_transmit, mpp_sync_self use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end @@ -498,9 +500,9 @@ module mpp_domains_mod private logical :: initialized=.false. integer(i8_kind) :: id=-9999 - integer(i8_kind) :: l_addr =-9999 - integer(i8_kind) :: l_addrx =-9999 - integer(i8_kind) :: l_addry =-9999 + type(c_ptr) :: l_addr =c_null_ptr + type(c_ptr) :: l_addrx =c_null_ptr + type(c_ptr) :: l_addry =c_null_ptr type(domain2D), pointer :: domain =>NULL() type(domain2D), pointer :: domain_in =>NULL() type(domain2D), pointer :: domain_out =>NULL() @@ -564,8 +566,8 @@ module mpp_domains_mod integer, dimension(MAX_REQUEST) :: type_recv integer, dimension(MAX_REQUEST) :: buffer_pos_send integer, dimension(MAX_REQUEST) :: buffer_pos_recv - integer(i8_kind) :: field_addrs(MAX_DOMAIN_FIELDS) - integer(i8_kind) :: field_addrs2(MAX_DOMAIN_FIELDS) + type(c_ptr) :: field_addrs(MAX_DOMAIN_FIELDS) + type(c_ptr) :: field_addrs2(MAX_DOMAIN_FIELDS) integer :: nfields end type nonblock_type @@ -616,9 +618,9 @@ module mpp_domains_mod integer :: unpack_ie(MAXOVERLAP) integer :: unpack_js(MAXOVERLAP) integer :: unpack_je(MAXOVERLAP) - integer(i8_kind) :: addrs_s(MAX_DOMAIN_FIELDS) - integer(i8_kind) :: addrs_x(MAX_DOMAIN_FIELDS) - integer(i8_kind) :: addrs_y(MAX_DOMAIN_FIELDS) + type(c_ptr) :: addrs_s(MAX_DOMAIN_FIELDS) + type(c_ptr) :: addrs_x(MAX_DOMAIN_FIELDS) + type(c_ptr) :: addrs_y(MAX_DOMAIN_FIELDS) integer :: buffer_start_pos = -1 integer :: request_send(MAX_REQUEST) integer :: request_recv(MAX_REQUEST) diff --git a/platform/platform.F90 b/platform/platform.F90 index e016ace5b9..8145c3d93e 100644 --- a/platform/platform.F90 +++ b/platform/platform.F90 @@ -29,7 +29,7 @@ module platform_mod integer, parameter :: r16_kind=QUAD_KIND, r8_kind=DOUBLE_KIND, r4_kind=FLOAT_KIND, & c8_kind=DOUBLE_KIND, c4_kind=FLOAT_KIND, & l8_kind=LONG_KIND, l4_kind=INT_KIND, & - i8_kind=LONG_KIND, i4_kind=INT_KIND, i2_kind=SHORT_KIND, & + i8_kind=LONG_KIND, i4_kind=INT_KIND, i2_kind=SHORT_KIND, i1_kind=BYTE_KIND, & ptr_kind=POINTER_KIND integer, parameter :: FMS_PATH_LEN = FMS_MAX_PATH_LEN integer, parameter :: FMS_FILE_LEN = FMS_MAX_FILE_LEN diff --git a/test_fms/mpp/test_mpp.F90 b/test_fms/mpp/test_mpp.F90 index 646fd4e16e..4d318cdf2c 100644 --- a/test_fms/mpp/test_mpp.F90 +++ b/test_fms/mpp/test_mpp.F90 @@ -21,19 +21,22 @@ program test !test various aspects of mpp_mod + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc use mpp_mod, only : mpp_init, mpp_exit, mpp_pe, mpp_npes, mpp_root_pe, mpp_commID, stdout use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_broadcast, mpp_transmit, mpp_sum, mpp_max, mpp_chksum, ALL_PES use mpp_mod, only : mpp_gather, mpp_error, FATAL, mpp_sync_self + use mpp_mod, only : get_pointer_address use platform_mod implicit none integer, parameter :: n=1048576 real, allocatable, dimension(:) :: a, b, c - real, allocatable, dimension(:) :: d - integer(i8_kind) :: locd + real, allocatable, dimension(:), target :: d + type(c_ptr) :: locd + integer(i8_kind) :: locd_i8 integer :: tick, tick0, ticks_per_sec, id integer :: pe, npes, root, i, j, k, l, m, n2, istat integer :: out_unit @@ -59,9 +62,10 @@ program test !test various aspects of mpp_mod !test of pointer sharing if( pe.EQ.root )then allocate( d(n) ) - locd = LOC(d) + locd = c_loc(d) + locd_i8 = get_pointer_address(locd) end if - call mpp_broadcast(locd,root) + call mpp_broadcast(locd_i8,root) if( pe.EQ.root )then call random_number(d) end if @@ -132,13 +136,13 @@ subroutine test_mpp_commID end subroutine test_mpp_commID subroutine test_shared_pointers(locd,n) - integer(i8_kind), intent(in) :: locd + type(c_ptr), intent(in) :: locd integer :: n - real :: dd(n) - pointer( p, dd ) + real, pointer :: dd(:) - p = locd - print *, 'TEST_SHARED_POINTERS: pe, locd=', pe, locd + call c_f_pointer(locd, dd, shape=[n]) + + print *, 'TEST_SHARED_POINTERS: pe, locd=', pe, get_pointer_address(locd) ! print *, 'TEST_SHARED_POINTERS: pe, chksum(d)=', pe, mpp_chksum(dd,(/pe/)) print *, 'TEST_SHARED_POINTERS: pe, sum(d)=', pe, sum(dd) return