ECC-2074: Fortran: get_message, new_from_message without memcpy

examples/F90/CMakeLists.txt

@@ -33,6 +33,7 @@ list( APPEND test_bins
     get_native_type
     get_product_kind
     grib_clone
+    grib_get_message
     grib_copy_message
     grib_copy_namespace
     grib_count_messages
@@ -99,6 +100,7 @@ if( HAVE_BUILD_TOOLS )
           codes_dump
           codes_scan_file
           codes_load_file
+	  grib_get_message
           grib_copy_message
           grib_sections_copy
           bufr_copy_message

examples/F90/grib_get_message.f90

@@ -0,0 +1,99 @@
+! (C) Copyright 2005- ECMWF.
+!
+! This software is licensed under the terms of the Apache Licence Version 2.0
+! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
+!
+! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
+! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
+!
+!
+!  Description: How to copy a GRIB message in memory
+!
+!
+program get
+   use eccodes
+   implicit none
+   integer                            :: err, centre
+   integer(kind=kindOfInt)           :: byte_size
+   integer(kind=kindOfInt)           :: byte_size2
+   integer                            :: infile, outfile1, outfile2
+   integer                            :: igrib_in
+   integer                            :: igrib_out
+   integer                            :: igrib_out2
+
+   character(len=1), dimension(:), pointer :: mptr
+   character(len=1), dimension(:), allocatable :: message
+   character(len=32)                  :: product_kind1
+   character(len=32)                  :: product_kind2
+
+   call codes_open_file(infile, '../../data/constant_field.grib1', 'r')
+   call codes_open_file(outfile1, 'out.get1.grib1', 'W')
+   call codes_open_file(outfile2, 'out.get2.grib1', 'W')
+
+   ! A new GRIB message is loaded from file
+   ! igrib_in is the GRIB id to be used in subsequent calls
+   call codes_grib_new_from_file(infile, igrib_in)
+
+   call codes_get_message_size(igrib_in, byte_size)
+   call grib_get_message(igrib_in, mptr, byte_size2)
+
+   if(byte_size == byte_size2) then
+           write(*,*) "Get message test 1 passed, message SIZES are the same!"
+   else
+           write(*,*) "Get message test 1 failed, message SIZES are NOT the same!"
+           call abort
+   endif
+
+   allocate (message(byte_size), stat=err)
+   call codes_copy_message(igrib_in, message)
+
+   if(ALL(mptr == message)) then
+           write(*,*) "Get message test 2 passed, message CONTENT is the same!"
+   else
+           write(*,*) "Get message test 2 failed, message CONTENT is NOT the same!"
+           call abort     
+   endif   
+
+   call codes_new_from_message(igrib_out, message)
+   call grib_new_from_message_no_copy(igrib_out2, mptr)
+
+   call codes_get(igrib_out, 'kindOfProduct', product_kind1)
+   write (*, *) 'allocatable kindOfProduct=', product_kind1
+   call codes_get(igrib_out2, 'kindOfProduct', product_kind2)
+   write (*, *) 'pointer kindOfProduct=', product_kind2
+   if(product_kind1 == product_kind2) then
+           write(*,*) "New from message (no copy) test 1 passed, GRIB_GET worked!"
+   else
+           write(*,*) "New from message (no copy) test 1 failed, GRIB_GET did NOT work!"
+           call abort
+   endif
+
+   centre = 75
+   call codes_set(igrib_out, 'centre', centre)
+   call codes_set(igrib_out2, 'centre', centre)
+
+   call codes_get(igrib_out, 'centre', centre)
+   write (*, *) 'allocatable centre=', centre
+   call codes_get(igrib_out2, 'centre', centre)
+   write (*, *) 'pointer centre=', centre
+
+  if(centre == 75) then
+           write(*,*) "New from message (no copy) test 2 passed, GRIB_SET worked!"
+   else
+           write(*,*) "New from message (no copy) test 2 failed, GRIB_SET did NOT work!"
+           call abort
+   endif
+
+   ! Write message to a file
+   call codes_write(igrib_out, outfile1)
+   call codes_write(igrib_out2, outfile2)
+
+   call codes_release(igrib_out)
+   call codes_release(igrib_in)
+   call codes_release(igrib_out2)
+   call codes_close_file(infile)
+   call codes_close_file(outfile1)
+   call codes_close_file(outfile2) 
+   deallocate (message)
+
+end program get 

examples/F90/grib_get_message.sh

@@ -0,0 +1,20 @@
+#!/bin/sh
+# (C) Copyright 2005- ECMWF.
+#
+# This software is licensed under the terms of the Apache Licence Version 2.0
+# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
+#
+# In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
+# virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
+
+. ./include.ctest.sh
+
+INPUT="../../data/constant_field.grib1"
+OUTPUT1=out.get1.grib1
+OUTPUT2=out.get2.grib1
+
+${examples_dir}/f_grib_get_message > /dev/null
+${tools_dir}/grib_compare $OUTPUT1 $OUTPUT2
+
+rm -f $OUTPUT1
+rm -f $OUTPUT2

fortran/grib_api_externals.h

@@ -21,7 +21,9 @@ integer, external :: grib_f_keys_iterator_get_name, &
                      grib_f_keys_iterator_rewind
 integer, external :: grib_f_new_from_message, &
                      grib_f_new_from_message_int, &
-                     grib_f_new_from_samples, &
+		     grib_f_new_from_message_no_copy, &
+                     grib_f_new_from_message_no_copy_int, &
+		     grib_f_new_from_samples, &
                      codes_bufr_f_new_from_samples, &
                      grib_f_read_any_from_file, &
                      any_f_new_from_file, &
@@ -77,7 +79,7 @@ integer, external :: grib_f_set_int, grib_f_set_int_array, &
                      grib_f_gribex_mode_on,grib_f_gribex_mode_off, &
                      codes_f_bufr_multi_element_constant_arrays_on,codes_f_bufr_multi_element_constant_arrays_off, &
                      grib_f_find_nearest_single,grib_f_find_nearest_four_single,grib_f_find_nearest_multiple
-integer, external :: grib_f_get_message_size, grib_f_copy_message, grib_f_count_in_file
+integer, external :: grib_f_get_message_size, grib_f_copy_message, grib_f_get_message, grib_f_count_in_file
 integer, external :: grib_f_write, grib_f_multi_write, grib_f_multi_append
 integer, external :: grib_f_clone, grib_f_copy_namespace
 external :: grib_f_check , grib_f_set_debug, grib_f_set_data_quality_checks

fortran/grib_api_visibility.h

@@ -10,15 +10,15 @@ public :: grib_skip_computed, &
           grib_skip_read_only
 public :: grib_keys_iterator_get_name, &
           grib_keys_iterator_rewind
-public :: grib_new_from_message, &
+public :: grib_new_from_message, grib_new_from_message_no_copy, &
           grib_new_from_samples, grib_new_from_file, &
           grib_read_from_file,grib_headers_only_new_from_file
 public :: grib_release
 public :: grib_dump
 public :: grib_get_error_string
 public :: grib_get_native_type
 public :: grib_get_size
-public :: grib_get_message_size, grib_copy_message
+public :: grib_get_message_size, grib_get_message, grib_copy_message
 public :: grib_write, grib_multi_append
 public :: grib_check
 public :: grib_clone, grib_copy_namespace

fortran/grib_f90_head.f90

@@ -41,6 +41,25 @@ module grib_api
     module procedure grib_new_from_message_int4
     module procedure grib_new_from_message_char
   end interface grib_new_from_message
+
+
+  !> Create a message pointing to an character array containting the coded message.
+  !>
+  !> The message can be accessed through its gribid and it will be available\n
+  !> until @ref grib_release is called or (attention) the character array is deallocated!
+  !>
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      id of the grib loaded in memory
+  !> @param message     array containing the coded message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error  
+  interface grib_new_from_message_no_copy
+    module procedure grib_new_from_message_no_copy_int4
+    module procedure grib_new_from_message_no_copy_char
+  end interface grib_new_from_message_no_copy
+
 
   !> Get a value of specified index from an array key.
   !>

fortran/grib_f90_int_size_t.f90

@@ -70,3 +70,17 @@
   interface grib_get_message_size
     module procedure grib_get_message_size_int
   end interface grib_get_message_size
+
+  !> Get the pointer and size of a coded message.
+  !>
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      id of the grib loaded in memory
+  !> @param message     pointer to the message
+  !> @param nbytes      size in bytes of the message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+  interface grib_get_message
+    module procedure grib_get_message_int
+  end interface grib_get_message

fortran/grib_f90_long_size_t.f90

@@ -81,3 +81,18 @@
     module procedure grib_get_message_size_int
     module procedure grib_get_message_size_size_t
   end interface grib_get_message_size
+
+  !> Get the pointer and size of a coded message.
+  !>
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      id of the grib loaded in memory
+  !> @param message     pointer to the message
+  !> @param nbytes      size in bytes of the message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+  interface grib_get_message
+    module procedure grib_get_message_int
+    module procedure grib_get_message_size_t
+  end interface grib_get_message

fortran/grib_f90_tail.f90

@@ -1370,6 +1370,67 @@ subroutine grib_new_from_message_char(gribid, message, status)
 
   end subroutine grib_new_from_message_char
 
+
+  !> Create a message pointing to an character array containting the coded message.
+  !>
+  !> The message can be accessed through its gribid and it will be available\n
+  !> until @ref grib_release is called or (attention) the character array is deallocated!
+  !>
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      id of the grib loaded in memory
+  !> @param message     array containing the coded message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+
+  subroutine grib_new_from_message_no_copy_char(gribid, message, status)
+    integer(kind=kindOfInt), intent(out)              :: gribid
+    character(len=1), dimension(:), intent(in)        :: message
+    integer(kind=kindOfInt), optional, intent(out)    :: status
+    integer(kind=kindOfSize_t)                        :: size_bytes
+    integer(kind=kindOfInt)                           :: iret
+
+    size_bytes = size(message, dim=1)
+    iret = grib_f_new_from_message_no_copy(gribid, message, size_bytes)
+    if (present(status)) then
+      status = iret
+    else
+      call grib_check(iret, 'new_from_message_no_copy_char', '')
+    end if
+
+  end subroutine grib_new_from_message_no_copy_char
+
+  !> Create a message pointing to an integer4 array containting the coded message.
+  !>
+  !> The message can be accessed through its gribid and it will be available\n
+  !> until @ref grib_release is called or (attention) the character array is deallocated!
+  !>
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      id of the grib loaded in memory
+  !> @param message     array containing the coded message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+
+  subroutine grib_new_from_message_no_copy_int4(gribid, message, status)
+    integer(kind=kindOfInt), intent(out)              :: gribid
+    integer(kind=4), dimension(:), intent(in)         :: message
+    integer(kind=kindOfInt), optional, intent(out)    :: status
+    integer(kind=kindOfSize_t)                        :: size_bytes
+    integer(kind=kindOfInt)                           :: iret
+
+    size_bytes = size(message, dim=1)*sizeOfInteger4
+    iret = grib_f_new_from_message_no_copy_int(gribid, message, size_bytes)
+    if (present(status)) then
+      status = iret
+    else
+      call grib_check(iret, 'new_from_message_no_copy_int', '')
+    end if
+
+  end subroutine grib_new_from_message_no_copy_int4
+
   !> Create a new message in memory from an integer array containting the coded message.
   !>
   !> The message can be accessed through its gribid and it will be available\n
@@ -2797,6 +2858,68 @@ subroutine grib_copy_message(gribid, message, status)
     end if
   end subroutine grib_copy_message
 
+  !> Get pointer to message and message length from the grib_handle.
+  !> Be careful, user has to manage deallocation via pointer or handle!
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      ID of the message loaded in memory
+  !> @param message     array containing the coded message
+  !> @param mess_len    length of the message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+ subroutine grib_get_message_size_t(gribid, message, mess_len, status)
+    USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER
+    implicit none
+    integer(kind=kindOfInt), intent(in)            :: gribid
+    integer(kind=kindOfInt), optional, intent(out) :: status
+    integer(kind=kindOfInt)                        :: iret
+    character(len=1), pointer, intent(out)         :: message(:) 
+    type(C_PTR)                                    :: mess_ptr
+    integer(kind=kindOfSize_t), intent(out)        :: mess_len
+
+    iret = grib_f_get_message(gribid, mess_ptr, mess_len)
+    call C_F_POINTER(mess_ptr, message,(/mess_len/))
+    if (present(status)) then
+      status = iret
+    else
+      call grib_check(iret, 'get_message', '')
+    end if
+  end subroutine grib_get_message_size_t
+
+!> Get pointer to message and message length from the grib_handle.
+  !> Be careful, user has to manage deallocation via pointer or handle!
+  !> In case of error, if the status parameter (optional) is not given, the program will
+  !> exit with an error message.\n Otherwise the error message can be
+  !> gathered with @ref grib_get_error_string.
+  !>
+  !> @param gribid      ID of the message loaded in memory
+  !> @param message     array containing the coded message
+  !> @param mess_len    length of the message
+  !> @param status      GRIB_SUCCESS if OK, integer value on error
+ subroutine grib_get_message_int(gribid, message, mess_len, status)
+    USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER
+    implicit none
+    integer(kind=kindOfInt), intent(in)            :: gribid
+    integer(kind=kindOfInt), optional, intent(out) :: status
+    integer(kind=kindOfInt)                        :: iret
+    character(len=1), pointer, intent(out)         :: message(:)
+    type(C_PTR)                                    :: mess_ptr
+    integer(kind=kindOfInt), intent(out)           :: mess_len
+    integer(kind=kindOfSize_t)                     :: ibytes
+
+    iret = grib_f_get_message(gribid, mess_ptr, ibytes)
+    call C_F_POINTER(mess_ptr, message,(/ibytes/))
+    if (iret == GRIB_SUCCESS .and. ibytes > huge(mess_len)) then
+      iret = GRIB_MESSAGE_TOO_LARGE
+    end if
+    mess_len = INT(ibytes, kind=kindOfInt)
+    if (present(status)) then
+      status = iret
+    else
+      call grib_check(iret, 'get_message', '')
+    end if
+  end subroutine grib_get_message_int
   !> Write the coded message to a file.
   !>
   !> In case of error, if the status parameter (optional) is not given, the program will