Remove cray pointers

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

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

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

mpp/include/group_update_unpack.inc

@@ -17,17 +17,19 @@
 !***********************************************************************
 
 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
      is = group%unpack_is(n); ie = group%unpack_ie(n)
      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

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_
 !> @}

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 )

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

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

mpp/include/mpp_do_check.fh

@@ -24,23 +24,24 @@
 
     !> 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  !<creates unique interface
       integer,                    intent(in) :: ke
       integer, optional,          intent(in) :: flags
       character(len=*), optional, intent(in) :: name
 
-      MPP_TYPE_ :: field(check%xbegin:check%xend, check%ybegin:check%yend,ke)
-      pointer(ptr_field, field)
+      MPP_TYPE_, pointer :: field(:,:,:)
+      MPP_TYPE_, pointer, contiguous :: tmpptr(:,:,:)
+      integer                     :: shape(3)
       integer                     :: update_flags
       character(len=8)            :: text
       character(len=64)           :: field_name
 
 !equate to mpp_domains_stack
-      MPP_TYPE_ :: buffer(size(mpp_domains_stack(:)))
-      pointer( ptr, buffer )
+      MPP_TYPE_, pointer :: buffer(:)
       integer :: buffer_pos
       integer,    allocatable :: msg1(:), msg2(:)
 !receive domains saved here for unpacking
@@ -51,8 +52,9 @@
       integer :: buffer_recv_size, nlist
       integer :: outunit
 
+      shape = [check%xend-check%xbegin+1, check%yend-check%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
@@ -149,7 +151,8 @@
             select case( check%recv(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(check%xbegin:check%xend, check%ybegin:check%yend, 1:ke) => 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