diff --git a/build/Makefile b/build/Makefile index 85d535e..bcc8325 100644 --- a/build/Makefile +++ b/build/Makefile @@ -102,6 +102,10 @@ run_util = \ runInfoType.f90 \ modelVarType.f90 \ ioModule.f90 \ + byte_utilities.f90 \ + messagepack_value.f90 \ + messagepack_user.f90 \ + messagepack.f90 \ runSnow17.f90 model_run = $(patsubst %, $(share_dir)/%, $(run_util)) diff --git a/src/bmi/bmi_snow17.f90 b/src/bmi/bmi_snow17.f90 index beeae15..39ab578 100644 --- a/src/bmi/bmi_snow17.f90 +++ b/src/bmi/bmi_snow17.f90 @@ -581,6 +581,10 @@ function snow17_var_type(this, name, type) result (bmi_status) character (len=*), intent(in) :: name character (len=*), intent(out) :: type integer :: bmi_status + character(len=BMI_MAX_TYPE_NAME) :: ser_create = "uint64" !pads spaces upto 2048. + character(len=BMI_MAX_TYPE_NAME) :: ser_size = "uint64" !pads spaces upto 2048 + character(len=BMI_MAX_TYPE_NAME) :: ser_state = "character" !pads spaces upto 2048 + character(len=BMI_MAX_TYPE_NAME) :: ser_free = "int" !pads spaces upto 2048 select case(name) case('tair', 'precip', & ! input/output vars @@ -600,6 +604,18 @@ function snow17_var_type(this, name, type) result (bmi_status) case('hru_id') type = "character" bmi_status = BMI_SUCCESS + case ('serialization_create') + type = ser_create + bmi_status = BMI_SUCCESS + case ('serialization_size') + type = ser_size + bmi_status = BMI_SUCCESS + case ('serialization_state') + type = ser_state + bmi_status = BMI_SUCCESS + case ('serialization_free') + type = ser_free + bmi_status = BMI_SUCCESS case default type = "-" bmi_status = BMI_FAILURE @@ -778,17 +794,35 @@ function snow17_var_nbytes(this, name, nbytes) result (bmi_status) integer, intent(out) :: nbytes integer :: bmi_status integer :: s1, s2, s3, grid, grid_size, item_size - s1 = this%get_var_grid(name, grid) - s2 = this%get_grid_size(grid, grid_size) - s3 = this%get_var_itemsize(name, item_size) - - if ((s1 == BMI_SUCCESS).and.(s2 == BMI_SUCCESS).and.(s3 == BMI_SUCCESS)) then - nbytes = item_size * grid_size - bmi_status = BMI_SUCCESS + + if (name == "serialization_create" .or. name == "serialization_size") then + nbytes = storage_size(0_int64)/8 !returns size in bits. So, divide by 8 for bytes. + bmi_status = BMI_SUCCESS + else if (name == "serialization_state") then + if(.not.allocated(this%model%serialization_buffer) .or. size(this%model%serialization_buffer) == 0) then + nbytes = -1 + call write_log("Serialization not set yet!", LOG_LEVEL_WARNING) + bmi_status = BMI_FAILURE + else + nbytes = size(this%model%serialization_buffer,KIND=int64) + bmi_status = BMI_SUCCESS + end if + else if (name == "serialization_free") then + nbytes = storage_size(0_int32)/8 !returns size in bits. So, divide by 8 for bytes. + bmi_status = BMI_SUCCESS else - nbytes = -1 - bmi_status = BMI_FAILURE - call write_log("snow17_var_nbytes - " // name // " not found.", LOG_LEVEL_SEVERE) + s1 = this%get_var_grid(name, grid) + s2 = this%get_grid_size(grid, grid_size) + s3 = this%get_var_itemsize(name, item_size) + + if ((s1 == BMI_SUCCESS).and.(s2 == BMI_SUCCESS).and.(s3 == BMI_SUCCESS)) then + nbytes = item_size * grid_size + bmi_status = BMI_SUCCESS + else + nbytes = -1 + bmi_status = BMI_FAILURE + call write_log("snow17_var_nbytes - " // name // " not found.", LOG_LEVEL_SEVERE) + end if end if end function snow17_var_nbytes @@ -818,6 +852,14 @@ function snow17_get_int(this, name, dest) result (bmi_status) ! case("model__identification_number") ! dest = [this%model%id] ! bmi_status = BMI_SUCCESS + case("serialization_size") + if(.not.allocated(this%model%serialization_buffer) .or. size(this%model%serialization_buffer) == 0) then + call write_log("Serialization not set yet!", LOG_LEVEL_WARNING) + bmi_status = BMI_FAILURE + else + dest = size(this%model%serialization_buffer,KIND=int64) + bmi_status = BMI_SUCCESS + end if case default dest(:) = -1 bmi_status = BMI_FAILURE @@ -991,6 +1033,9 @@ function snow17_get_ptr_int(this, name, dest_ptr) result (bmi_status) !==================== UPDATE IMPLEMENTATION IF NECESSARY FOR INTEGER VARS ================= select case(name) + case("serialization_state") + dest_ptr = this%model%serialization_buffer + bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE call write_log("snow17_get_ptr_int - " // name // " not found.", LOG_LEVEL_SEVERE) @@ -1094,6 +1139,7 @@ function snow17_set_int(this, name, src) result (bmi_status) character (len=*), intent(in) :: name integer, intent(in) :: src(:) integer :: bmi_status + integer(kind=int64) :: exec_status !==================== UPDATE IMPLEMENTATION IF NECESSARY FOR INTEGER VARS ================= @@ -1101,7 +1147,24 @@ function snow17_set_int(this, name, src) result (bmi_status) ! case("model__identification_number") ! this%model%id = src(1) ! bmi_status = BMI_SUCCESS - case default + case("serialization_create") + call new_serialization_request(this%model, exec_status) + if (exec_status == 0) then + bmi_status = BMI_SUCCESS + call write_log("Serialization for state saving complete", LOG_LEVEL_INFO) + else + bmi_status = BMI_FAILURE + call write_log(" Failed to create serialized data for state saving", LOG_LEVEL_FATAL) + end if + case("serialization_state") + call deserialize_mp_buffer(this%model,src) + bmi_status = BMI_SUCCESS + case("serialization_free") + if(allocated(this%model%serialization_buffer)) then + deallocate(this%model%serialization_buffer) + end if + bmi_status = BMI_SUCCESS + case default bmi_status = BMI_FAILURE call write_log("snow17_set_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select diff --git a/src/share/byte_utilities.f90 b/src/share/byte_utilities.f90 new file mode 100644 index 0000000..fb3e2e9 --- /dev/null +++ b/src/share/byte_utilities.f90 @@ -0,0 +1,328 @@ +module byte_utilities + use iso_fortran_env + use,intrinsic :: ieee_arithmetic + implicit none + public + contains + logical function detect_little_endian() + ! used by the library to detect host endianness + ! Note: DOES NOT HANDLE MIDDLE-ENDIAN + ! @returns .true. if little endian, .false. otherwise + detect_little_endian = (1 == transfer([1_int8, 0_int8], 0_int16) ) + end function + + subroutine print_endianness() + ! debugging function to print out whether the library + ! thinks the host system is little or big endian + if (detect_little_endian()) then + print *, "Detected System Endianness: Little" + else + print *, "Detected System Endiannes: Big" + end if + end subroutine + + ! BIG ENDIAN bytes ==> LITTLE ENDIAN + integer(kind=int16) function bytes_be_int_le_2(bytes) + ! converts bytes in big-endian to an int16 in little endian + byte, dimension(2), intent(in) :: bytes + bytes_be_int_le_2 = transfer([bytes(2), bytes(1)], 0_int16) + end function + + integer(kind=int32) function bytes_be_int_le_4(bytes) + ! converts bytes in big-endian to an int32 in little endian + byte, dimension(4), intent(in) :: bytes + bytes_be_int_le_4 = transfer([bytes(4), bytes(3), bytes(2), bytes(1)], 0_int32) + end function + + integer(kind=int64) function bytes_be_int_le_8(bytes) + ! converts bytes in big-endian to an int64 in little endian + byte, dimension(8), intent(in) :: bytes + bytes_be_int_le_8 = transfer([bytes(8), bytes(7), bytes(6), bytes(5), & + bytes(4), bytes(3), bytes(2), bytes(1)], 0_int64) + end function + + real(kind=real32) function bytes_be_real_le_4(bytes) + ! converts bytes in big-endian to a real32 in little endian + byte, dimension(4), intent(in) :: bytes + bytes_be_real_le_4 = transfer([bytes(4), bytes(3), bytes(2), bytes(1)], 1.0_real32) + end function + + real(kind=real64) function bytes_be_real_le_8(bytes) + ! converts bytes in big-endian to a real64 in little endian + byte, dimension(8), intent(in) :: bytes + bytes_be_real_le_8 = transfer([bytes(8), bytes(7), bytes(6), bytes(5), & + bytes(4), bytes(3), bytes(2), bytes(1)], 1.0_real64) + end function + + ! BIG ENDIAN bytes ==> BIG ENDIAN + integer(kind=int16) function bytes_be_int_be_2(bytes) + ! converts bytes in big-endian to an int16 in big endian + byte, dimension(2), intent(in) :: bytes + bytes_be_int_be_2 = transfer([bytes(1), bytes(2)], 0_int16) + end function + + integer(kind=int32) function bytes_be_int_be_4(bytes) + ! converts bytes in big-endian to an int32 in big endian + byte, dimension(4), intent(in) :: bytes + bytes_be_int_be_4 = transfer([bytes(1), bytes(2), bytes(3), bytes(4)], 0_int32) + end function + + integer(kind=int64) function bytes_be_int_be_8(bytes) + ! converts bytes in big-endian to an int64 in big endian + byte, dimension(8), intent(in) :: bytes + bytes_be_int_be_8 = transfer([bytes(1), bytes(2), bytes(3), bytes(4), & + bytes(5), bytes(6), bytes(7), bytes(8)], 0_int64) + end function + + real(kind=real32) function bytes_be_real_be_4(bytes) + ! converts bytes in big-endian to a real32 in big endian + byte, dimension(4), intent(in) :: bytes + bytes_be_real_be_4 = transfer([bytes(1), bytes(2), bytes(3), bytes(4)], 1.0_real32) + end function + + real(kind=real64) function bytes_be_real_be_8(bytes) + ! converts bytes in big-endian to a real32 in big endian + byte, dimension(8), intent(in) :: bytes + bytes_be_real_be_8 = transfer([bytes(1), bytes(2), bytes(3), bytes(4), & + bytes(5), bytes(6), bytes(7), bytes(8)], 1.0_real64) + end function + + integer(kind=int16) function bytes_be_to_int_2(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(2), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_2 = bytes_be_int_le_2(bytes) + else + bytes_be_to_int_2 = bytes_be_int_be_2(bytes) + end if + end function + + integer(kind=int32) function bytes_be_to_int_4(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_4 = bytes_be_int_le_4(bytes) + else + bytes_be_to_int_4 = bytes_be_int_be_4(bytes) + end if + end function + + integer(kind=int64) function bytes_be_to_int_8(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_8 = bytes_be_int_le_8(bytes) + else + bytes_be_to_int_8 = bytes_be_int_be_8(bytes) + end if + end function + + real(kind=real32) function bytes_be_to_real_4(bytes, e) + ! converts bytes in big-endian to a real32 based on requested endianness + ! @param[in] e - .true. for little endian, .false for big endian + byte, dimension(4), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_real_4 = bytes_be_real_le_4(bytes) + else + bytes_be_to_real_4 = bytes_be_real_be_4(bytes) + end if + end function + + real(kind=real64) function bytes_be_to_real_8(bytes, e) + ! converts bytes in big-endian to a real64 based on requested endianness + ! @param[in] e - .true. for little endian, .false for big endian + byte, dimension(8), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_real_8 = bytes_be_real_le_8(bytes) + else + bytes_be_to_real_8 = bytes_be_real_be_8(bytes) + end if + end function + + ! LITTLE ENDIAN ==> BIG ENDIAN bytes + subroutine int_le_to_bytes_be_2(bytes, value) + ! converts int16 little endian to bytes in big-endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + bytes(1) = int(ibits(value, 8, 8), kind=int8) + bytes(2) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine int_le_to_bytes_be_4(bytes, value) + ! converts int32 little endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + bytes(1) = int(ibits(value, 24, 8), kind=int8) + bytes(2) = int(ibits(value, 16, 8), kind=int8) + bytes(3) = int(ibits(value, 8, 8), kind=int8) + bytes(4) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine int_le_to_bytes_be_8(bytes, value) + ! converts int64 little endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + bytes(1) = int(ibits(value, 56, 8), kind=int8) + bytes(2) = int(ibits(value, 48, 8), kind=int8) + bytes(3) = int(ibits(value, 40, 8), kind=int8) + bytes(4) = int(ibits(value, 32, 8), kind=int8) + bytes(5) = int(ibits(value, 24, 8), kind=int8) + bytes(6) = int(ibits(value, 16, 8), kind=int8) + bytes(7) = int(ibits(value, 8, 8), kind=int8) + bytes(8) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine real_le_to_bytes_be_4(bytes, value) + ! convert real32 little endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + bytes(4:1:-1) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_le_to_bytes_be_8(bytes, value) + ! convert real64 little endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + bytes(8:1:-1) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + ! BIG ENDIAN ==> BIG ENDIAN bytes + subroutine int_be_to_bytes_be_2(bytes, value) + ! converts int16 big endian to bytes in big-endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + bytes(1:2) = transfer(value, [0_int8, 0_int8]) + end subroutine + + subroutine int_be_to_bytes_be_4(bytes, value) + ! converts int32 big endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + bytes(1:4) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine int_be_to_bytes_be_8(bytes, value) + ! converts int64 big endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + bytes(1:8) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_be_to_bytes_be_4(bytes, value) + ! converts real32 big endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + bytes(1:4) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_be_to_bytes_be_8(bytes, value) + ! converts real64 big endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + bytes(1:8) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine int_to_bytes_be_2(bytes, value) + ! converts int16 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_2(bytes, value) + else + call int_be_to_bytes_be_2(bytes, value) + end if + end subroutine + + subroutine int_to_bytes_be_4(bytes, value) + ! converts int32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_4(bytes, value) + else + call int_be_to_bytes_be_4(bytes, value) + end if + end subroutine + + subroutine int_to_bytes_be_8(bytes, value) + ! converts int64 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_8(bytes, value) + else + call int_be_to_bytes_be_8(bytes, value) + end if + end subroutine + + subroutine real_to_bytes_be_4(bytes, value) + ! converts real32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + if (detect_little_endian()) then + call real_le_to_bytes_be_4(bytes, value) + else + call real_be_to_bytes_be_4(bytes, value) + end if + end subroutine + + subroutine real_to_bytes_be_8(bytes, value) + ! converts real32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + if (detect_little_endian()) then + call real_le_to_bytes_be_8(bytes, value) + else + call real_be_to_bytes_be_8(bytes, value) + end if + end subroutine + + integer(kind=int16) function int8_as_unsigned(value) + ! interprets an unsigned int8 value as a signed value + ! by increasing the storage width + integer(kind=int8), intent(in) :: value + + int8_as_unsigned = value + if (value < 0) then + int8_as_unsigned = iand(int8_as_unsigned, 255_int16) + end if + end function + + integer(kind=int32) function int16_as_unsigned(value) + ! interprets an unsigned int16 value as a signed value + ! by increasing the storage width + integer(kind=int16), intent(in) :: value + + int16_as_unsigned = value + if (value < 0) then + int16_as_unsigned = iand(int16_as_unsigned, 65535_int32) + end if + end function + + integer(kind=int64) function int32_as_unsigned(value) + ! interprets an unsigned int32 value as a signed value + ! by increasing the storage width + integer(kind=int32), intent(in) :: value + + int32_as_unsigned = value + if (value < 0) then + int32_as_unsigned = iand(int32_as_unsigned, 4294967295_int64) + end if + end function +end module diff --git a/src/share/messagepack.f90 b/src/share/messagepack.f90 new file mode 100644 index 0000000..1d4c2a5 --- /dev/null +++ b/src/share/messagepack.f90 @@ -0,0 +1,107 @@ +module messagepack + + ! implement buffer or c++ vector + ! implement static buffer? + ! implement packing + ! implement unpacking + ! implement file io + use iso_fortran_env + use messagepack_value + use messagepack_user + use byte_utilities + + implicit none +contains + + subroutine print_bytes_as_hex(bytes, addhexmark) + ! prints a buffer of bytes as the unsigned hex version + ! @param[in] bytes - byte buffer to print + ! @param[in] addhexmark - If true, print with 0x prepended + ! @returns none + byte, dimension(:), allocatable, intent(in) :: bytes + logical, intent(in) :: addhexmark + + integer :: i + integer :: val + write(*, "(A2)", advance="no") "[ " + if (addhexmark) then + do i = 1,size(bytes) + val = int8_as_unsigned(bytes(i)) + write(*, '("0x", Z2.2, " ")', advance="no") val + end do + else + do i = 1,size(bytes) + val = int8_as_unsigned(bytes(i)) + write(*, '(Z2.2, " ")', advance="no") val + end do + end if + write(*,*) "]" + end subroutine + + subroutine unpack_array_int_1d(obj, om, errored) + ! Attempts to unpack a 1d messagepack array of integers + ! Note: does not check `is_unsigned`. + ! @param[in] obj - messagepack object + ! @param[out] om - dynamically allocated matrix + ! @param[out] errored - .true. if an error occurred + class(mp_value_type), allocatable, intent(in) :: obj + integer(kind=int64), dimension(:), allocatable, intent(out) :: om + logical, intent(out) :: errored + + ! variables + logical :: stat + integer(kind=int64) :: i, val, l + class(mp_arr_type), allocatable :: arr + + errored = .true. + call get_arr_ref(obj, arr, stat) + if (.not.(stat)) then + return + end if + ! initialize output + l = arr%numelements() + allocate(om(l)) + do i = 1,l + call get_int(arr%values(i)%obj, val, stat) + if (.not.(stat)) then + return + end if + om(i) = val + end do + errored = .false. + end subroutine + + subroutine unpack_array_real_1d(obj, om, errored) + ! Attempts to unpack a 1d messagepack array of reals + ! @param[in] obj - messagepack object + ! @param[out] om - dynamically allocated matrix + ! @param[out] errored - .true. if an error occurred + class(mp_value_type), allocatable, intent(in) :: obj + real(kind=real64), dimension(:), allocatable, intent(out) :: om + logical, intent(out) :: errored + + ! variables + logical :: stat + integer(kind=int64) :: i, l + real(kind=real64) :: val + class(mp_arr_type), allocatable :: arr + + errored = .true. + call get_arr_ref(obj, arr, stat) + if (.not.(stat)) then + return + end if + ! initialize output + l = arr%numelements() + allocate(om(l)) + do i = 1,l + call get_real(arr%values(i)%obj, val, stat) + if (.not.(stat)) then + return + end if + om(i) = val + end do + errored = .false. + end subroutine + +end module diff --git a/src/share/messagepack_user.f90 b/src/share/messagepack_user.f90 new file mode 100644 index 0000000..fa2394a --- /dev/null +++ b/src/share/messagepack_user.f90 @@ -0,0 +1,1169 @@ +! defines a class that stores callbacks for handling +! user extensions +module messagepack_user + use iso_fortran_env + use, intrinsic :: ieee_arithmetic + use messagepack_value + use byte_utilities + + implicit none + + private + + public :: msgpack, unpack_func, unpack_callback + public :: mp_timestamp_type, is_timestamp, get_timestamp_ref, register_extension + + integer, parameter, public :: MP_TS_EXT = -1 + + abstract interface + subroutine unpack_func(buffer, byteadvance, is_little_endian, mpv, successful) + import int64, mp_value_type + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + end subroutine + end interface + + type :: unpack_callback + procedure(unpack_func), pointer, nopass :: cb => null() + end type + + ! top level class where user is expected to interact with + ! messagepack utilities + type :: msgpack + class(unpack_callback), allocatable, dimension(:) :: f1 + class(unpack_callback), allocatable, dimension(:) :: f2 + class(unpack_callback), allocatable, dimension(:) :: f4 + class(unpack_callback), allocatable, dimension(:) :: f8 + class(unpack_callback), allocatable, dimension(:) :: f16 + class(unpack_callback), allocatable, dimension(:) :: e8 + class(unpack_callback), allocatable, dimension(:) :: e16 + class(unpack_callback), allocatable, dimension(:) :: e32 + logical, dimension(256) :: f1_allocated + logical, dimension(256) :: f2_allocated + logical, dimension(256) :: f4_allocated + logical, dimension(256) :: f8_allocated + logical, dimension(256) :: f16_allocated + logical, dimension(256) :: e8_allocated + logical, dimension(256) :: e16_allocated + logical, dimension(256) :: e32_allocated + + logical :: is_little_endian + logical :: fail_flag + character(:), allocatable :: error_message + logical :: extra_bytes + contains + procedure :: register_extension + procedure :: register_extension_super + procedure :: print_value + procedure :: print_value_with_args + procedure :: print_version + procedure :: failed + procedure :: pack_alloc + procedure :: pack_prealloc + procedure :: unpack + procedure :: unpack_buf + procedure :: is_available + procedure :: unpack_value + procedure :: unpack_map + procedure :: unpack_ext + procedure :: unpack_array + procedure :: extra_bytes_is_error + procedure :: check_size + end type + interface msgpack + procedure :: new_mp + end interface + + ! #region messagepack defined extensions go here + type, extends(mp_value_type) :: mp_timestamp_type + integer(kind=int64) :: seconds + integer(kind=int64) :: nanoseconds ! this must be positive + contains + procedure :: getsize => get_size_timestamp + procedure :: pack => pack_timestamp + end type + interface mp_timestamp_type + procedure :: new_timestamp + end interface + ! #endregion + + contains + type(msgpack) function new_mp() + logical :: err + procedure(unpack_func), pointer :: p + integer :: i + allocate(new_mp%f1(256)) + allocate(new_mp%f2(256)) + allocate(new_mp%f4(256)) + allocate(new_mp%f8(256)) + allocate(new_mp%f16(256)) + allocate(new_mp%e8(256)) + allocate(new_mp%e16(256)) + allocate(new_mp%e32(256)) + do i = 1,256 + new_mp%f1_allocated = .false. + new_mp%f2_allocated = .false. + new_mp%f4_allocated = .false. + new_mp%f8_allocated = .false. + new_mp%f16_allocated = .false. + new_mp%e8_allocated = .false. + new_mp%e16_allocated = .false. + new_mp%e32_allocated = .false. + end do + + ! AFAIK there is no stdlib equivalent of C++20 std::endian + new_mp%is_little_endian = detect_little_endian() + new_mp%fail_flag = .false. + new_mp%error_message = '' + new_mp%extra_bytes = .true. + + ! add timestamp here + p => unpack_timestamp_32 + call new_mp%register_extension_super(MP_FE4, -1_int8, p, err) + p => unpack_timestamp_64 + call new_mp%register_extension_super(MP_FE8, -1_int8, p, err) + p => unpack_timestamp_96 + call new_mp%register_extension_super(MP_E8, -1_int8, p, err) + end function + + subroutine extra_bytes_is_error(this, val) + ! manipulate this flag + class(msgpack) :: this + logical, intent(in) :: val + this%extra_bytes = val + end subroutine + + subroutine print_version(this) + class(msgpack) :: this + print *, "0.3.1" + end subroutine + + logical function failed(this) + class(msgpack) :: this + failed = this%fail_flag + end function + + type(mp_timestamp_type) function new_timestamp(sec, ns) + integer(kind=int64) :: sec + integer(kind=int64) :: ns + new_timestamp%seconds = sec + new_timestamp%nanoseconds = abs(ns) + end function + + subroutine register_extension(this, ext, typeid, cb, error) + ! Registers callbacks for handling extensions + ! Only allows registering ids [0 127] + class(msgpack) :: this + integer, intent(in) :: ext + integer(kind=int8), intent(in) :: typeid + procedure(unpack_func), pointer, intent(in) :: cb + logical, intent(out) :: error + + if (typeid < 0) then + error = .true. + return + end if + call this%register_extension_super(ext, typeid, cb, error) + end subroutine + + subroutine register_extension_super(this, ext, typeid, cb, error) + ! Registers callbacks for handling extensions + ! allows ids [-128 127] + class(msgpack) :: this + integer, intent(in) :: ext + integer(kind=int8), intent(in) :: typeid + procedure(unpack_func), pointer, intent(in) :: cb + logical, intent(out) :: error + + integer :: arr_index + + arr_index = typeid + 129 ! [-128, 127] -> [1, 256] + + select case(ext) + case (MP_FE1) + this%f1(arr_index)%cb => cb + this%f1_allocated(arr_index) = .true. + case (MP_FE2) + this%f2(arr_index)%cb => cb + this%f2_allocated(arr_index) = .true. + case (MP_FE4) + this%f4(arr_index)%cb => cb + this%f4_allocated(arr_index) = .true. + case (MP_FE8) + this%f8(arr_index)%cb => cb + this%f8_allocated(arr_index) = .true. + case (MP_FE16) + this%f16(arr_index)%cb => cb + this%f16_allocated(arr_index) = .true. + case (MP_E8) + this%e8(arr_index)%cb => cb + this%e8_allocated(arr_index) = .true. + case (MP_E16) + this%e16(arr_index)%cb => cb + this%e16_allocated(arr_index) = .true. + case (MP_E32) + this%e32(arr_index)%cb => cb + this%e16_allocated(arr_index) = .true. + end select + + error = .false. + end subroutine + + ! PACKING + subroutine pack_alloc(this, mpv, buffer) + ! Packs a messagepack object into a dynamically + ! allocated buffer, returned to the user. The user + ! must handle deallocation. + ! @param[in] this - self + ! @param[in] mpv - messagepack value to pack + ! @param[out] buffer - will contain serialized data + class(msgpack) :: this + class(mp_value_type) :: mpv + byte, allocatable, dimension(:), intent(out) :: buffer + integer(kind=int64) :: dblen + integer(kind=int64) :: numused + + call mpv%getsize(dblen) ! get buffer size required + allocate(buffer(dblen)) ! allocate buffer + + call mpv%pack(buffer, numused, this%fail_flag) + if (.not.(this%fail_flag)) then + if (dblen /= numused) then + this%fail_flag = .true. + this%error_message = 'Internal Error: packing failed' + end if + end if + end subroutine + + subroutine pack_prealloc(this, mpv, bytes_used, buffer) + ! Packs a messagepack object into a pre-allocated buffer, + ! returned to the user. This function does not check beforehand + ! for the array being the correct size, and will return an error + ! if the buffer is too small. + class(msgpack) :: this + class(mp_value_type) :: mpv + integer(kind=int64), intent(out) :: bytes_used + byte, allocatable, dimension(:), intent(inout) :: buffer + + call mpv%pack(buffer, bytes_used, this%fail_flag) + end subroutine + + subroutine unpack(this, buffer, mpv) + ! Unpack a MsgPack value from a buffer. + ! - nominally contains a single value + ! @param[in] this - self + ! @param[in] buffer - serialized messagepack data + ! @param[out] mpv - Deserialized value + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + class(mp_value_type), allocatable, intent(out) :: mpv + + integer(kind=int64) :: numbytes + + call this%unpack_buf(buffer, mpv, numbytes) + if (numbytes < size(buffer) .and. this%extra_bytes) then + ! configurable error + this%fail_flag = .true. + write(this%error_message, '(i0) (A)') size(buffer) - numbytes, ' extra bytes unused' + else if (numbytes > size(buffer)) then + this%fail_flag = .true. ! bug within reporting byte mechanism + write(this%error_message, '(A) (i0)') "internal error. number of bytes exceeds buffer size by: ", & + numbytes - size(buffer) + end if + end subroutine + + subroutine unpack_buf(this, buffer, mpv, numbytes) + ! Unpack a single value from a buffer. Additionally returns + ! the number of bytes used, in case the buffer has multiple + ! MessagePack values within it or is a rolling buffer, etc. + ! @param[in] this - self + ! @param[in] buffer - serialized messagepack data + ! @param[out] mpv - Deserialized value + ! @param[out] numbytes - Number of bytes used in the buffer + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + class(mp_value_type), allocatable, intent(out) :: mpv + integer(kind=int64), intent(out) :: numbytes + + logical :: successful + + this%fail_flag = .false. + call this%unpack_value(buffer, numbytes, mpv, successful) + this%fail_flag = .not.(successful) + + if (numbytes > size(buffer)) then + this%fail_flag = .true. ! bug within reporting byte mechanism + write(this%error_message, '(A) (i0)') "internal error. number of bytes exceeds buffer size by: ", & + numbytes - size(buffer) + end if + end subroutine + + logical function is_available(this, buffer) + ! Returns true if the buffer contains at least 1 complete + ! messagepack value + ! @param[in] this - instance + ! @param[in] buffer - serialized data + ! @returns - .true. if a complete messagepack value exists + class(msgpack) :: this + byte, dimension(:) :: buffer + + logical :: error + integer(kind=int64) :: numbytes + + call this%check_size(buffer, .true., numbytes, error) + is_available = .not.(error) + end function + + subroutine print_value(this, obj) + ! Prints MessagePack object with default options + ! @param[in] this - instance + ! @param[in] obj - MessagePack object to print + class(msgpack) :: this + class(mp_value_type), intent(in) :: obj + call this%print_value_with_args(obj, 0, .false., -1) + end subroutine + + recursive subroutine print_value_with_args(this, obj, indentation, & + sameline, maxelems) + ! Prints MessagePack object with a variety of configurability + ! @param[in] this - instance + ! @param[in] obj - MessagePack object to print in a pretty fashion + ! @param[in] indentation - number of levels of indentation to print with + ! @param[in] sameline - if true, compacts the output + ! @param[in] maxelems - if non-negative, limits number of elements printed + ! @returns None + class(msgpack), intent(in) :: this + class(mp_value_type), intent(in) :: obj + integer, intent(in) :: indentation + logical, intent(in) :: sameline + integer, intent(in) :: maxelems + integer(kind=int64) :: i, j, ind + + if (.not. sameline) then + do i = 1,indentation + write(*, "(A2)", advance="no") " " + end do + end if + + select type(obj) + class is (mp_nil_type) + write(*, "(A)", advance="no") "nil" + class is (mp_bool_type) + if (obj%value) then + write(*, "(A)", advance="no") "true" + else + write(*, "(A)", advance="no") "false" + end if + class is (mp_int_type) + if (obj%unsigned_64) then + write(*, "(I0, A)", advance="no") obj%value, "[OUT-OF-RANGE]" + else + write(*, "(I0)", advance="no") obj%value + end if + + class is (mp_float_type) + if (obj%is_64) then + write(*, "(F0.0)", advance="no") obj%f64value + else + write(*, "(F0.0)", advance="no") obj%f32value + end if + class is (mp_str_type) + write(*, "(A, A, A)", advance="no") char(34), obj%value, char(34) + class is (mp_arr_type) + write(*, "(A)", advance="no") "[" + printarr : do j = 1,obj%numelements() + call this%print_value_with_args(obj%values(j)%obj, 0, .true., maxelems) + write(*, "(A)", advance="no") ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A3)") "..." + exit printarr + end if + end do printarr + write(*, "(A)", advance="no") "]" + class is (mp_map_type) + write(*, "(A)") "{" + printmap : do j = 1, obj%numelements() + do i = 1,indentation+1 + write(*, "(A2)", advance="no") " " + end do + call this%print_value_with_args(obj%keys(j)%obj, indentation + 1, & + .true., maxelems) + write(*, "(A)", advance="no") " => " + call this%print_value_with_args(obj%values(j)%obj, indentation + 1, & + .true., maxelems) + print *, "," + if (maxelems > 0 .and. i > maxelems) then + write(*, "(A3)") "..." + exit printmap + end if + end do printmap + if (.not. sameline) then + do i = 1,indentation + write(*, "(A2)", advance="no") " " + end do + end if + write(*, "(A)") "}," + class is (mp_bin_type) + write(*, "(A)", advance="no") "BIN[" + printbin : do j = 1,obj%numelements() + write(*, "(I0, A)", advance="no") obj%values(j), ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A)") "..." + exit printbin + end if + end do printbin + write(*, "(A)", advance="no") "]" + class is (mp_ext_type) + ind = obj%exttype + 129 ! TODO + write(*, "(A)", advance="no") "EXT[" + printext : do j = 1,obj%numelements() + write(*, "(I0, A)", advance="no") obj%values(j), ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A)") "..." + exit printext + end if + end do printext + write(*, "(A)", advance="no") "]" + end select + if (.not. sameline) then + print *, "" + end if + end subroutine + + subroutine get_size_timestamp(this, osize) + class(mp_timestamp_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%nanoseconds == 0 .and. this%seconds <= 4294967296_int64 .and. & + this%seconds >= 0) then + osize = 6 ! timestamp32 + else if (this%nanoseconds <= 1073741824_int64 & + .and. this%seconds <= 17179869184_int64 & + .and. this%seconds >= 0) then + ! nanoseconds fit into uint30, seconds fit into uint34 + osize = 10 ! timestamp32 + else + osize = 15 ! timestamp96 + end if + end subroutine + + subroutine pack_timestamp(this, buf, num, error) + class(mp_timestamp_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + integer(kind=int64) :: temp + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + select case (num) + case (6) ! timestamp32 + buf(1) = MP_FE4 + buf(2) = MP_TS_EXT + call int_to_bytes_be_4(buf(3:6), int(this%seconds, kind=int32)) + case (10) ! timestamp64 + buf(1) = MP_FE8 + buf(2) = MP_TS_EXT + temp = this%seconds + call mvbits(this%seconds, 0, 34, temp, 0) + call mvbits(this%nanoseconds, 0, 30, temp, 34) + call int_to_bytes_be_8(buf(3:10), temp) + case (15) ! timestamp96 + buf(1) = MP_E8 + buf(2) = 12 + buf(3) = MP_TS_EXT + call int_to_bytes_be_4(buf(4:7), int(this%nanoseconds, kind=int32)) + call int_to_bytes_be_8(buf(8:15), this%seconds) + end select + + error = .false. + end subroutine + + subroutine unpack_timestamp_32(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int32) :: temp + + if (size(buffer(byteadvance+1:)) < 4) then + successful = .false. + return + end if + + temp = bytes_be_to_int_4(buffer(byteadvance+1:byteadvance+4), is_little_endian) + mpv = mp_timestamp_type(temp, 0) + byteadvance = byteadvance + 4 + + successful = .true. + end subroutine + + subroutine unpack_timestamp_64(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: temp, temp1, temp2 + + if (size(buffer(byteadvance+1:)) < 8) then + successful = .false. + return + end if + + temp = bytes_be_to_int_8(buffer(byteadvance+1:byteadvance+8), is_little_endian) + temp1 = 0 + temp2 = 0 + call mvbits(temp, 0, 34, temp1, 0) + call mvbits(temp, 34, 30, temp2, 0) + mpv = mp_timestamp_type(temp1, temp2) + byteadvance = byteadvance + 8 + + successful = .true. + end subroutine + + subroutine unpack_timestamp_96(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int32) :: temp + integer(kind=int64) :: temp2 + + if (size(buffer(byteadvance+1:)) < 12) then + successful = .false. + return + end if + + temp = bytes_be_to_int_4(buffer(byteadvance+1:byteadvance+4), is_little_endian) + byteadvance = byteadvance + 4 + temp2 = bytes_be_to_int_8(buffer(byteadvance+1:byteadvance+8), is_little_endian) + mpv = mp_timestamp_type(temp2, temp) + byteadvance = byteadvance + 8 + + successful = .true. + end subroutine + + function is_timestamp(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type(obj) + class is (mp_timestamp_type) + res = .true. + class default + res = .false. + end select + end function is_timestamp + + subroutine get_timestamp_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_timestamp_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_timestamp_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + ! unpacking shenanigans + recursive subroutine check_size(this, buffer, recurse, & + byteadvance, error) + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + logical, intent(in) :: recurse + integer(kind=int64), intent(out) :: byteadvance + logical, intent(out) :: error + + ! temp variables + integer(kind=int64) :: length, i64_temp, i + byte :: i8_temp + integer(kind=int16) :: i16_temp + integer(kind=int32) :: i32_temp + + ! set default output values + error = .false. + byteadvance = 1 + + ! need to have data available to read + length = size(buffer) + if (length == 0) then + error = .true. + this%error_message = 'buffer is empty' + return + end if + + select case(buffer(1)) + case (MP_PFI_L:MP_PFI_H, MP_NIL, MP_T, MP_F) + ! only a single byte is needed, all good + case (MP_U8, MP_I8) + byteadvance = 2 + case (MP_U16, MP_I16, MP_FE1) + byteadvance = 3 + case (MP_FE2) + byteadvance = 4 + case (MP_U32, MP_I32, MP_F32) + byteadvance = 5 + case (MP_FE4) + byteadvance = 6 + case (MP_U64, MP_I64, MP_F64) + byteadvance = 9 + case (MP_FE8) + byteadvance = 10 + case (MP_FE16) + byteadvance = 18 + ! dynamic length values + case (MP_FS_L:MP_FS_H) + ! length in first 5 bits + i8_temp = 0 + call mvbits(buffer(1), 0, 5, i8_temp, 0) ! get fixstr length + byteadvance = 1_int64 + i8_temp + case (MP_S8, MP_B8) + ! length with 1 byte + i32_temp = int8_as_unsigned(buffer(2)) + byteadvance = 1 + i32_temp + case (MP_S16, MP_B16) + ! length with 2 byte + i16_temp = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + byteadvance = 1 + i16_temp + if (length < 1 + byteadvance) then + error = .true. + end if + case (MP_S32, MP_B32) + ! length with 4 byte + i32_temp = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + byteadvance = 1 + i32_temp + if (length < 1 + i32_temp) then + error = .true. + end if + ! containers + case (MP_FA_L:MP_FA_H, MP_FM_L:MP_FM_H) + ! length with first 4 bits + i8_temp = 0 + call mvbits(buffer(1), 0, 4, i8_temp, 0) ! get fixarr, fixmap length + ! recurse + if (recurse) then + do i = 1,i8_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + case (MP_A16, MP_M16) + ! length with 2 byte + byteadvance = 3 + if (length < byteadvance) then + error = .true. + return + end if + i16_temp = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + ! recurse + if (recurse) then + do i = 1,i16_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + case (MP_A32, MP_M32) + ! length with 4 byte + byteadvance = 5 + if (length < byteadvance) then + error = .true. + return + end if + i32_temp = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + ! recurse + if (recurse) then + do i = 1,i32_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + end select + if (length < byteadvance) then + error = .false. + end if + if (error) then + this%error_message = 'not enough bytes' + end if + end subroutine + + recursive subroutine unpack_value(this, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(out) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + ! other variables to use + integer(kind=int64) :: length + integer :: i + integer(kind=int64) :: i_64 + byte :: btemp1 ! byte temp value + integer(kind=int16) :: val_int16 + integer(kind=int32) :: val_int32 + integer(kind=int64) :: val_int64 + + integer(kind=int64) :: i64_temp + character(:), allocatable :: val_char + + logical :: error + + length = size(buffer) + + ! set default output values + successful = .true. + + ! need to have data available to read + if (length == 0) then + successful = .false. + this%error_message = 'buffer is empty' + return + end if + + ! check that the size for the entire header exists + call this%check_size(buffer, .true., i64_temp, error) + if (error) then + successful = .false. + this%error_message = 'insufficient size' + return + end if + + byteadvance = 1 ! default output value + select case (buffer(1)) + case (MP_PFI_L:MP_PFI_H) + ! the byte itself is the value + mpv = mp_int_type(buffer(1)) + case (MP_FM_L:MP_FM_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 4, btemp1, 0) ! get fixmap length + val_int64 = btemp1 + byteadvance = 1 + call this%unpack_map(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_FA_L:MP_FA_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 4, btemp1, 0) ! get fixarray length + byteadvance = 1 + call this%unpack_array(btemp1 + 0_int64, buffer, byteadvance, & + mpv, successful) + case (MP_FS_L:MP_FS_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 5, btemp1, 0) ! get fixstr length + allocate(character(btemp1) :: val_char) + do i = 1,btemp1 + val_char(i:i) = transfer(buffer(1 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + btemp1 + case (MP_NIL) + ! default is already nil + mpv = mp_nil_type() + case (MP_NU) + successful = .false. + this%error_message = 'Never Used detected. Invalid MsgPack' + case (MP_F) + mpv = mp_bool_type(.false.) + case (MP_T) + mpv = mp_bool_type(.true.) + ! binary format family + case (MP_B8) + val_int32 = int8_as_unsigned(buffer(2)) + val_int64 = val_int32 + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(3:2+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin8 cast' + end select + byteadvance = 2 + val_int64 + case (MP_B16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int64 = int16_as_unsigned(val_int16) + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(4:3+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin16 bad cast' + end select + byteadvance = 3 + val_int64 + case (MP_B32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(6:5+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin32 bad cast' + end select + byteadvance = 5 + val_int64 + case (MP_E8) + ! check for first 3 bytes + i = buffer(3) + byteadvance = 3 + call this%unpack_ext(int8_as_unsigned(buffer(2)) + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_E16) + ! check for first 4 bytes + i = buffer(4) + byteadvance = 4 + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + call this%unpack_ext(val_int16 + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_E32) + ! check for first 6 bytes + i = buffer(6) + byteadvance = 6 + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + call this%unpack_ext(val_int32 + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_F32) + ! 4 bytes following + mpv = new_real32(bytes_be_to_real_4(buffer(2:5), & + this%is_little_endian)) + byteadvance = 5 + case (MP_F64) + ! 8 bytes following + mpv = new_real64(bytes_be_to_real_8(buffer(2:9), this%is_little_endian)) + byteadvance = 9 + ! Unsigned integers >>> + ! need to watch when grabbed values are negative + case (MP_U8) + ! 1 byte following + mpv = mp_int_type(int8_as_unsigned(buffer(2))) + byteadvance = 2 + case (MP_U16) + ! 2 bytes following + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + mpv = mp_int_type(int16_as_unsigned(val_int16)) + byteadvance = 3 + case (MP_U32) + ! 4 bytes following + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + mpv = mp_int_type(int32_as_unsigned(val_int32)) + byteadvance = 5 + case (MP_U64) + ! 8 bytes following + val_int64 = bytes_be_to_int_8(buffer(2:9), this%is_little_endian) + if (val_int64 >= 0) then + mpv = mp_int_type(val_int64) + else + mpv = mp_int_type(val_int64) + call set_unsigned(mpv) + end if + byteadvance = 9 + ! Signed integers >>> + case (MP_I8) + ! 1 byte following + mpv = mp_int_type(buffer(2)) + byteadvance = 2 + case (MP_I16) + ! 2 bytes following + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + mpv = mp_int_type(val_int32) + byteadvance = 3 + case (MP_I32) + ! 4 bytes following + mpv = mp_int_type(bytes_be_to_int_4(buffer(2:5), this%is_little_endian)) + byteadvance = 5 + case (MP_I64) + ! 8 bytes following + mpv = mp_int_type(bytes_be_to_int_8(buffer(2:9), this%is_little_endian)) + byteadvance = 9 + ! ext format family + case (MP_FE1) + ! 3 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(1_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE2) + ! 4 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(2_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE4) + ! 6 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(4_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE8) + ! 8 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(8_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE16) + ! 18 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(16_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_S8) + val_int16 = int8_as_unsigned(buffer(2)) + ! create string + allocate(character(val_int16) :: val_char) + do i = 1,val_int16 + val_char(i:i) = transfer(buffer(2 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + val_int16 + case (MP_S16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + ! create string + allocate(character(val_int32) :: val_char) + do i = 1,val_int32 + val_char(i:i) = transfer(buffer(3 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + val_int32 + case (MP_S32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + ! create string + allocate(character(val_int64) :: val_char) + do i_64 = 1_int64,val_int64 + val_char(i_64:i_64) = transfer(buffer(3 + i_64), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1_int64 + val_int64 + case (MP_A16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + byteadvance = 3 + call this%unpack_array(int(val_int32, kind=int64), & + buffer, byteadvance, mpv, successful) + case (MP_A32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + byteadvance = 5 + call this%unpack_array(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_M16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + byteadvance = 3 + call this%unpack_map(0_int64 + val_int32, buffer, byteadvance, & + mpv, successful) + case (MP_M32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + byteadvance = 5 + call this%unpack_map(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_NFI_L:MP_NFI_H) + ! it's the straight bit pattern there + mpv = mp_int_type(buffer(1)) + end select + end subroutine + + recursive subroutine unpack_array(this, length, buffer, & + byteadvance, mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: i, tmp + class(mp_value_type), allocatable :: val_any + mpv = mp_arr_type(length) + do i = 1,length + call this%unpack_value(buffer(byteadvance+1:), tmp, & + val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + + ! store the newly unpacked object into the array + select type (mpv) + class is (mp_arr_type) + mpv%values(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_array bad cast' + end select + end do + end subroutine + + recursive subroutine unpack_map(this, length, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: i, tmp + class(mp_value_type), allocatable :: val_any + + successful = .true. + mpv = mp_map_type(length) + do i = 1,length + ! get key + call this%unpack_value(buffer(byteadvance+1:), & + tmp, val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + select type (mpv) + class is (mp_map_type) + mpv%keys(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_map bad cast' + end select + + ! get value + call this%unpack_value(buffer(byteadvance+1:), tmp, & + val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + select type (mpv) + class is (mp_map_type) + mpv%values(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + print *, "[Error: something went terribly wrong" + end select + end do + end subroutine + + subroutine unpack_ext(this, length, etype, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + integer, intent(in) :: etype + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer :: ind + if (length > size(buffer)) then + successful = .false. + return + end if + + ! Custom extension handling + ind = etype + 129 + if (ind < 1 .or. ind > 256) then + successful = .false. + return + end if + if (length == 1) then + if (this%f1_allocated(ind)) then + call this%f1(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 2) then + if (this%f2_allocated(ind)) then + call this%f2(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 4) then + if (this%f4_allocated(ind)) then + call this%f4(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 8) then + if (this%f8_allocated(ind)) then + call this%f8(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 16) then + if (this%f16_allocated(ind)) then + call this%f16(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 256) then + if (this%e8_allocated(ind)) then + call this%e8(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 65536) then + if (this%e16_allocated(ind)) then + call this%e16(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 4294967296_int64) then + if (this%e32_allocated(ind)) then + call this%e32(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + end if + + ! regular extension + mpv = mp_ext_type(etype, length) + successful = .true. + select type(mpv) + class is (mp_ext_type) + mpv%values = buffer(byteadvance+1:byteadvance+length) + byteadvance = byteadvance + length + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_ext bad cast' + end select + end subroutine +end module diff --git a/src/share/messagepack_value.f90 b/src/share/messagepack_value.f90 new file mode 100644 index 0000000..e3044e1 --- /dev/null +++ b/src/share/messagepack_value.f90 @@ -0,0 +1,1162 @@ +module messagepack_value + use iso_fortran_env + use,intrinsic :: ieee_arithmetic + use byte_utilities + + implicit none + + ! taken directly from https://github.com/msgpack/msgpack/blob/master/spec.md#formats + integer, parameter, public :: MP_PFI_L = 0 ! pos fixint low - 0x00 + integer, parameter, public :: MP_PFI_H = 127 ! pos fixint high - 0x7f + ! because fortran integers are always signed, we are going to perceive values + ! as signed even though they're supposed to be unsigned. + ! the following values are negative as that is how fortran will see them + integer, parameter, public :: MP_FM_L = -128 ! fixmap low - 0x80 + integer, parameter, public :: MP_FM_H = -113 ! fixmap high - 0x8f + integer, parameter, public :: MP_FA_L = -112 ! fixarray low - 0x90 + integer, parameter, public :: MP_FA_H = -97 ! fixarray high - 0x9f + integer, parameter, public :: MP_FS_L = -96 ! fixstr low - 0xa0 + integer, parameter, public :: MP_FS_H = -65 ! fixstr high - 0xbf + integer, parameter, public :: MP_NIL = -64 ! nil - 0xc0 + integer, parameter, public :: MP_NU = -63 ! never used - 0cx1 + integer, parameter, public :: MP_F = -62 ! false - 0xc2 + integer, parameter, public :: MP_T = -61 ! true - 0xc3 + integer, parameter, public :: MP_B8 = -60 ! bin8 - 0xc4 + integer, parameter, public :: MP_B16 = -59 ! bin16 - 0xc5 + integer, parameter, public :: MP_B32 = -58 ! bin32 - 0xc6 + integer, parameter, public :: MP_E8 = -57 ! ext8 - 0xc7 + integer, parameter, public :: MP_E16 = -56 ! ext16 - 0xc8 + integer, parameter, public :: MP_E32 = -55 ! ext32 - 0xc9 + integer, parameter, public :: MP_F32 = -54 ! float32 - 0xca + integer, parameter, public :: MP_F64 = -53 ! float64 - 0xcb + integer, parameter, public :: MP_U8 = -52 ! uint8 - 0xcc + integer, parameter, public :: MP_U16 = -51 ! uint16 - 0xcd + integer, parameter, public :: MP_U32 = -50 ! uint32 - 0xce + integer, parameter, public :: MP_U64 = -49 ! uint64 - 0xcf + integer, parameter, public :: MP_I8 = -48 ! int8 - 0xd0 + integer, parameter, public :: MP_I16 = -47 ! int16 - 0xd1 + integer, parameter, public :: MP_I32 = -46 ! int32 - 0xd2 + integer, parameter, public :: MP_I64 = -45 ! int64 - 0xd3 + integer, parameter, public :: MP_FE1 = -44 ! fixext1 - 0xd4 + integer, parameter, public :: MP_FE2 = -43 ! fixext2 - 0xd5 + integer, parameter, public :: MP_FE4 = -42 ! fixext4 - 0xd6 + integer, parameter, public :: MP_FE8 = -41 ! fixext8 - 0xd7 + integer, parameter, public :: MP_FE16 = -40 ! fixext16 - 0xd8 + integer, parameter, public :: MP_S8 = -39 ! str8 - 0xd9 + integer, parameter, public :: MP_S16 = -38 ! str16 - 0xda + integer, parameter, public :: MP_S32 = -37 ! str32 - 0xdb + integer, parameter, public :: MP_A16 = -36 ! array16 - 0xdc + integer, parameter, public :: MP_A32 = -35 ! array32 - 0xdd + integer, parameter, public :: MP_M16 = -34 ! map16 - 0xde + integer, parameter, public :: MP_M32 = -33 ! map32 - 0xdf + integer, parameter, public :: MP_NFI_L = -32 ! neg fixint low - 0xe0 + integer, parameter, public :: MP_NFI_H = -1 ! neg fixint high - 0xff + + private + + public :: mp_value_type, mp_nil_type, mp_bool_type, mp_int_type, mp_float_type, mp_str_type, mp_bin_type + public :: mp_arr_type, mp_map_type, mp_ext_type + public :: is_nil, is_bool, is_int, is_float, is_str, is_bin, is_arr, is_map, is_ext + public :: new_real32, new_real64 + public :: set_unsigned, is_unsigned + public :: get_bool, get_int, get_real, get_str, get_bin, get_arr_ref, get_map_ref, get_ext_ref + + type, abstract :: mp_value_type + ! nothing here + contains + procedure :: getsize => get_size_1 + procedure :: pack => pack_value + procedure :: numelements => return_one + end type + + ! pointer handler for container types + type :: mp_value_type_ptr + class(mp_value_type), allocatable :: obj + end type + + type, extends(mp_value_type) :: mp_nil_type + ! nothing here + contains + procedure :: getsize => get_size_nil + procedure :: pack => pack_nil + end type + + type, extends(mp_value_type) :: mp_bool_type + ! nothing here + logical :: value + contains + procedure :: getsize => get_size_bool + procedure :: pack => pack_bool + end type + interface mp_bool_type + procedure :: new_bool + end interface mp_bool_type + + type, extends(mp_value_type) :: mp_int_type + ! fortran integers are signed. since MsgPack defines unsigned integers, + ! this needs to handle the case where a uint64 is unpacked, or the user + ! wants to serialize a uint64, which is the only case where this matters + ! the `unsigned` flag will go high when this is detected during unpacking + integer(kind=int64) :: value + logical :: unsigned_64 = .false. + contains + procedure :: getsize => get_size_int + procedure :: pack => pack_int + end type + interface mp_int_type + procedure :: new_int + end interface mp_int_type + + type, extends(mp_value_type) :: mp_float_type + ! simply create memory for both 32bit & 64bit floats + ! with a logical indicating which one is being used + real(kind=real64) :: f64value + real(kind=real32) :: f32value + logical :: is_64 = .false. + contains + procedure :: getsize => get_size_float + procedure :: pack => pack_float + end type + interface mp_float_type + procedure :: new_real32 + procedure :: new_real64 + end interface + + type, extends(mp_value_type) :: mp_str_type + character(:), allocatable :: value + contains + procedure :: getsize => get_size_str + procedure :: pack => pack_str + end type + interface mp_str_type + procedure :: new_str + end interface mp_str_type + + type, extends(mp_value_type) :: mp_bin_type + byte, allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_bin + procedure :: numelements => get_bin_size + procedure :: pack => pack_bin + end type + interface mp_bin_type + procedure :: new_bin + procedure :: new_bin_64 + end interface mp_bin_type + + type, extends(mp_value_type) :: mp_arr_type + class(mp_value_type_ptr), allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_arr + procedure :: numelements => get_arr_size + procedure :: pack => pack_arr + end type + interface mp_arr_type + procedure :: new_arr + procedure :: new_arr_64 + end interface mp_arr_type + + type, extends(mp_value_type) :: mp_map_type + class(mp_value_type_ptr), allocatable, dimension(:) :: keys + class(mp_value_type_ptr), allocatable, dimension(:) :: values + integer(kind=int64) :: ne + contains + procedure :: getsize => get_size_map + procedure :: numelements => get_map_size + procedure :: pack => pack_map + end type + interface mp_map_type + procedure :: new_map + procedure :: new_map_64 + end interface mp_map_type + + type, extends(mp_value_type) :: mp_ext_type + integer :: exttype + byte, allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_ext + procedure :: numelements => get_ext_size + procedure :: pack => pack_ext + end type + interface mp_ext_type + procedure :: new_ext + end interface mp_ext_type + + contains + subroutine get_size_1(this, osize) + class(mp_value_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + integer function return_zero(obj) + class(mp_value_type) :: obj + return_zero = 0 + end function + + integer(kind=int64) function return_one(obj) + class(mp_value_type) :: obj + return_one = 1_int64 + end function + + subroutine get_size_nil(this, osize) + class(mp_nil_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + subroutine get_size_bool(this, osize) + class(mp_bool_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + subroutine get_size_int(this, osize) + class(mp_int_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%value < 0) then + if (this%value >= -32) then + osize = 1 ! negative fixint + else if (this%value >= -128) then + osize = 2 ! int8 + else if (this%value >= -32768) then + osize = 3 ! int16 + else if (this%value >= -2147483648_int64) then + osize = 5 ! int32 + else + osize = 9 ! int64 & uint64 + end if + else + if (this%value <= 127) then + osize = 1 ! positive fixint + else if (this%value <= 255) then + osize = 2 ! uint8 + else if (this%value <= 65535) then + osize = 3 ! uint16 + else if (this%value <= 4294967295_int64) then + osize = 5 ! uint32 + else + osize = 9 ! uint64 & int64 + end if + end if + end subroutine + + subroutine get_size_float(this, osize) + class(mp_float_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%is_64) then + osize = 9 ! real64 + else + osize = 5 ! real32 + end if + end subroutine + + integer function get_str_type(length) + ! get type of string based on length of the string + integer(kind=int64), intent(in) :: length + if (length <= 31) then + get_str_type = MP_FS_L + int(length, kind=int8) + else if (length <= 255) then + get_str_type = MP_S8 + else if (length <= 65535) then + get_str_type = MP_S16 + else if (length <= 4294967295_int64) then + get_str_type = MP_S32 + else + get_str_type = MP_NU ! bad + end if + end function + + integer function get_bin_type(length) + ! get type of bin based on length of data + integer(kind=int64), intent(in) :: length + if (length <= 255) then + get_bin_type = MP_B8 + else if (length <= 65535) then + get_bin_type = MP_B16 + else if (length <= 4294967295_int64) then + get_bin_type = MP_B32 + else + get_bin_type = MP_NU ! bad + end if + end function + + integer function get_arr_type(length) + ! get type of array based on length of the array + integer(kind=int64), intent(in) :: length + if (length <= 15) then + get_arr_type = int(ior(MP_FA_L, int(length)), kind=int8) + else if (length <= 65535) then + get_arr_type = MP_A16 + else if (length <= 4294967295_int64) then + get_arr_type = MP_A32 + else + get_arr_type = MP_NU ! bad + end if + end function + + integer function get_map_type(length) + ! get type of map based on length of the map + integer(kind=int64), intent(in) :: length + if (length <= 15) then + get_map_type = int(ior(MP_FM_L, int(length)), kind=int8) + else if (length <= 65535) then + get_map_type = MP_M16 + else if (length <= 4294967295_int64) then + get_map_type = MP_M32 + else + get_map_type = MP_NU ! bad + end if + end function + + integer function get_ext_type(length) + ! get type of extension based on the length + integer(kind=int64), intent(in) :: length + if (length == 1) then + get_ext_type = MP_FE1 + else if (length == 2) then + get_ext_type = MP_FE2 + else if (length == 4) then + get_ext_type = MP_FE4 + else if (length == 8) then + get_ext_type = MP_FE8 + else if (length == 16) then + get_ext_type = MP_FE16 + else if (length <= 255) then + get_ext_type = MP_E8 + else if (length <= 65535) then + get_ext_type = MP_E16 + else if (length <= 4294967295_int64) then + get_ext_type = MP_E32 + else + get_ext_type = MP_NU ! bad + end if + end function + + subroutine get_size_str(this, osize) + class(mp_str_type) :: this + integer(kind=int64), intent(out) :: osize + integer(kind=int64) :: length + length = len(this%value) + select case(get_str_type(length)) + case (MP_FS_L:MP_FS_H) + osize = length + 1 + case (MP_S8) + osize = length + 2 ! str8 + case (MP_S16) + osize = length + 3 ! str16 + case (MP_S32) + osize = length + 5 ! str32 + case default + osize = 0 + print *, "WARNING BAD STRING" + end select + end subroutine + + subroutine get_size_bin(this, osize) + class(mp_bin_type) :: this + integer(kind=int64), intent(out) :: osize + integer :: length + length = size(this%values) + if (length <= 255) then + osize = length + 2 ! bin8 + else if (length <= 65535) then + osize = length + 3 ! bin16 + else + osize = length + 5 ! bin32 + end if + ! TODO handle longer than error case + end subroutine + + subroutine get_size_arr(this, osize) + class(mp_arr_type) :: this + integer(kind=int64), intent(out) :: osize + integer(kind=int64) i, elemsize, length + + length = size(this%values) + ! set initial value + if (length <= 15) then + osize = 1 ! fixarray + else if (length <= 65535) then + osize = 3 ! array16 + else + osize = 5 ! array32 + end if + ! TODO error handling for larger + + ! get sizes of all contained values + do i = 1, length + call this%values(i)%obj%getsize(elemsize) + osize = osize + elemsize + end do + end subroutine + + subroutine get_size_map(this, osize) + class(mp_map_type) :: this + integer(kind=int64), intent(out) :: osize + + integer(kind=int64) keysize, valuesize, i + ! set initialsize + if (this%ne <= 15) then + osize = 1 ! fixmap + else if (this%ne <= 65535) then + osize = 3 ! map16 + else + osize = 5 ! map32 + end if + ! TODO handle errors for larger + + ! get sizes of all contained values + do i = 1, this%ne + call this%keys(i)%obj%getsize(keysize) + call this%values(i)%obj%getsize(valuesize) + osize = osize + keysize + valuesize + end do + end subroutine + + subroutine get_size_ext(this, osize) + class(mp_ext_type) :: this + integer(kind=int64), intent(out) :: osize + integer :: length + + length = size(this%values) + if (length == 1) then + osize = 3 ! fixext1 + else if (length == 2) then + osize = 4 ! fixext2 + else if (length == 4) then + osize = 6 ! fixext4 + else if (length == 8) then + osize = 10 ! fixext8 + else if (length == 16) then + osize = 18 ! fixext16 + else if (length <= 255) then + osize = 3 + length ! ext8 + else if (length <= 65535) then + osize = 4 + length ! ext16 + else + osize = 6 + length ! ext32 + end if + end subroutine + + subroutine pack_value(this, buf, num, error) + class(mp_value_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + print *, "[Error: abstract pack function called" + error = .true. ! this function should never be called + end subroutine + + subroutine pack_nil(this, buf, num, error) + class(mp_nil_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + if (size(buf) < 1) then + error = .true. + return + end if + + buf(1) = MP_NIL + num = 1 + error = .false. + end subroutine + + subroutine pack_bool(this, buf, num, error) + class(mp_bool_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + if (size(buf) < 1) then + error = .true. + return + end if + + if (this%value) then + buf(1) = MP_T + else + buf(1) = MP_F + end if + error = .false. + num = 1 + end subroutine + + subroutine pack_int(this, buf, num, error) + class(mp_int_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + error = .false. + if (this%value < 0) then + if (this%value >= -32) then + ! negative fixint - copy bits over + buf(1) = int(this%value, kind=int8) + else if (this%value >= -128) then + ! int8 + buf(1) = MP_I8 + buf(2) = int(this%value, kind=int8) + else if (this%value >= -32768) then + ! int16 + buf(1) = MP_I16 + call int_to_bytes_be_2(buf(2:3), int(this%value, kind=int16)) + else if (this%value >= -2147483648_int64) then + ! int32 + buf(1) = MP_I32 + call int_to_bytes_be_4(buf(2:5), int(this%value, kind=int32)) + else + if (this%unsigned_64) then + ! uint64 + buf(1) = MP_U64 + else + ! int64 + buf(1) = MP_I64 + end if + call int_to_bytes_be_8(buf(2:9), int(this%value, kind=int64)) + end if + else + if (this%value <= 127) then + buf(1) = int(this%value, kind=int8) + else if (this%value <= 255) then + ! uint8 + buf(1) = MP_U8 + buf(2) = int(this%value, kind=int8) + else if (this%value <= 65535) then + ! uint16 + buf(1) = MP_U16 + call int_to_bytes_be_2(buf(2:3), int(this%value, kind=int16)) + else if (this%value <= 4294967295_int64) then + ! uint32 + buf(1) = MP_U32 + call int_to_bytes_be_4(buf(2:5), int(this%value, kind=int32)) + else + if (this%unsigned_64) then + ! uint64 + buf(1) = MP_U64 + else + ! int64 + buf(1) = MP_I64 + end if + call int_to_bytes_be_8(buf(2:9), int(this%value, kind=int64)) + end if + end if + end subroutine + + subroutine pack_float(this, buf, num, error) + class(mp_float_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize value + if (this%is_64) then + buf(1) = MP_F64 + call real_to_bytes_be_8(buf(2:9), this%f64value) + else + buf(1) = MP_F32 + call real_to_bytes_be_4(buf(2:5), this%f32value) + end if + + error = .false. + end subroutine + + subroutine pack_str(this, buf, num, error) + class(mp_str_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer :: strtype + integer :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = len(this%value) + strtype = get_str_type(length) + buf(1) = int(strtype, kind=int8) ! write marker + + select case(strtype) + case (MP_FS_L:MP_FS_H) + writeindex = 1 + case (MP_S8) + writeindex = 2 + buf(2) = int(length, kind=int8) + case (MP_S16) + writeindex = 3 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_S32) + writeindex = 5 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + end select + do i = 1,length + buf(writeindex+i) = transfer(this%value(i:i), 0_int8) + end do + error = .false. + end subroutine + + subroutine pack_bin(this, buf, num, error) + class(mp_bin_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer :: writeindex + integer :: bintype + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + bintype = get_bin_type(length) + buf(1) = int(bintype, kind=int8) ! write marker + + select case(bintype) + case (MP_B8) + writeindex = 3 + buf(2) = int(length, kind=int8) + case (MP_B16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_B32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + buf(writeindex:writeindex+length-1) = this%values + + error = .false. + end subroutine + + recursive subroutine pack_arr(this, buf, num, error) + class(mp_arr_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length, temp + integer :: arrtype + integer(kind=int64) :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + arrtype = get_arr_type(length) + buf(1) = int(arrtype, kind=int8) ! write marker + + select case(arrtype) + case (MP_FA_L:MP_FA_H) + writeindex = 2 + case (MP_A16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_A32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + do i = 1,length + call this%values(i)%obj%pack(buf(writeindex:), temp, error) + writeindex = writeindex + temp + if (error) then + return + end if + end do + + error = .false. + end subroutine + + recursive subroutine pack_map(this, buf, num, error) + class(mp_map_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length, temp + integer :: maptype + integer(kind=int64) :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + maptype = get_map_type(length) + buf(1) = int(maptype, kind=int8) ! write marker + + select case(maptype) + case (MP_FM_L:MP_FM_H) + writeindex = 2 + case (MP_M16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_M32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + do i = 1,length + call this%keys(i)%obj%pack(buf(writeindex:), temp, error) + if (error) then + return + end if + writeindex = writeindex + temp + call this%values(i)%obj%pack(buf(writeindex:), temp, error) + if (error) then + return + end if + writeindex = writeindex + temp + end do + + error = .false. + end subroutine + + subroutine pack_ext(this, buf, num, error) + class(mp_ext_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer(kind=int64) :: etype + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize data + length = this%numelements() + etype = get_ext_type(length) + buf(1) = int(etype, kind=int8) ! write marker + + select case(etype) + case (MP_FE1, MP_FE2, MP_FE4, MP_FE8, MP_FE16) + buf(2) = int(this%exttype, kind=int8) + buf(3:3+length-1) = this%values + case (MP_E8) + buf(2) = int(length, kind=int8) + buf(3) = int(this%exttype, kind=int8) + buf(4:4+length-1) = this%values + case (MP_E16) + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + buf(4) = int(this%exttype, kind=int8) + buf(5:5+length-1) = this%values + case (MP_E32) + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + buf(6) = int(this%exttype, kind=int8) + buf(7:7+length-1) = this%values + case (MP_NU) + error = .true. + return + end select + + error = .false. + end subroutine + + function is_nil(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_nil_type) + res = .true. + class default + res = .false. + end select + end function is_nil + + function is_bool(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_bool_type) + res = .true. + class default + res = .false. + end select + end function is_bool + + function is_int(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_int_type) + res = .true. + class default + res = .false. + end select + end function is_int + + function is_float(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_float_type) + res = .true. + class default + res = .false. + end select + end function is_float + + function is_str(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_str_type) + res = .true. + class default + res = .false. + end select + end function is_str + + function is_bin(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_bin_type) + res = .true. + class default + res = .false. + end select + end function is_bin + + function is_arr(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_arr_type) + res = .true. + class default + res = .false. + end select + end function is_arr + + function is_map(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_map_type) + res = .true. + class default + res = .false. + end select + end function is_map + + function is_ext(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_ext_type) + res = .true. + class default + res = .false. + end select + end function is_ext + + type(mp_bool_type) function new_bool(arg) + logical, intent(in) :: arg + new_bool%value = arg + end function new_bool + + type(mp_int_type) function new_int(arg) + ! generic constructor for integers + integer(kind=int64), intent(in) :: arg + new_int%value = arg + end function new_int + + subroutine set_unsigned(obj) + ! Changes the unsigned_64 flag to true for packing purposes + class(mp_value_type), intent(inout) :: obj + select type (obj) + class is (mp_int_type) + obj%unsigned_64 = .true. + end select + end subroutine + + logical function is_unsigned(obj) + class(mp_value_type), intent(in) :: obj + select type (obj) + class is (mp_int_type) + is_unsigned = obj%unsigned_64 + class default + is_unsigned = .false. + end select + end function + + type(mp_float_type) function new_real32(arg) + real(kind=real32), intent(in) :: arg + new_real32%f32value = arg + new_real32%f64value = 0.0 + new_real32%is_64 = .false. + end function new_real32 + + type(mp_float_type) function new_real64(arg) + real(kind=real64), intent(in) :: arg + new_real64%f32value = 0.0 + new_real64%f64value = arg + new_real64%is_64 = .true. + end function new_real64 + + type(mp_str_type) function new_str(arg) + character(:), allocatable :: arg + new_str%value = arg + end function new_str + + type(mp_bin_type) function new_bin(length) + integer, intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_bin%values(length)) + end function new_bin + + type(mp_bin_type) function new_bin_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_bin_64%values(length)) + end function new_bin_64 + + type(mp_arr_type) function new_arr(length) + integer, intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_arr%values(length)) + end function new_arr + + type(mp_arr_type) function new_arr_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_arr_64%values(length)) + end function new_arr_64 + + type(mp_map_type) function new_map(length) + integer, intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated map with size greater than packing allows" + end if + allocate(new_map%keys(length)) + allocate(new_map%values(length)) + new_map%ne = length + end function new_map + + type(mp_map_type) function new_map_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated map with size greater than packing allows" + end if + allocate(new_map_64%keys(length)) + allocate(new_map_64%values(length)) + new_map_64%ne = length + end function new_map_64 + + type(mp_ext_type) function new_ext(etype, length) + integer, intent(in) :: etype + integer(kind=int64), intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated ext with size greater than packing allows" + end if + + new_ext%exttype = etype + allocate(new_ext%values(length)) + end function new_ext + + subroutine get_bool(obj, val, stat) + class(mp_value_type), intent(in) :: obj + logical, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_bool_type) + val = obj%value + stat = .true. + class default + val = .false. + stat = .false. + end select + end subroutine + + subroutine get_int(obj, val, stat) + class(mp_value_type), intent(in) :: obj + integer(kind=int64), intent(out) :: val + logical, intent(out) :: stat + ! emulate is_int + select type (obj) + class is (mp_int_type) + val = obj%value + stat = .true. + class default + val = 0 + stat = .false. + end select + end subroutine + + subroutine get_real(obj, val, stat) + class(mp_value_type), intent(in) :: obj + real(kind=real64), intent(out) :: val + logical, intent(out) :: stat + + select type (obj) + class is (mp_float_type) + if (obj%is_64) then + val = obj%f64value + else + val = obj%f32value + end if + stat = .true. + class default + val = 0 + stat = .false. + end select + end subroutine + + subroutine get_str(obj, val, stat) + class(mp_value_type), intent(in) :: obj + character(:), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type (obj) + class is (mp_str_type) + val = obj%value + stat = .true. + class default + val = "" + stat = .false. + end select + end subroutine + + subroutine get_bin(obj, val, stat) + class(mp_value_type), intent(in) :: obj + byte, allocatable, dimension(:), intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_bin_type) + val = obj%values + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_arr_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_arr_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_arr_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_map_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_map_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_map_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_ext_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_ext_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_ext_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + integer(kind=int64) function get_bin_size(obj) + class(mp_bin_type) :: obj + get_bin_size = size(obj%values) + end function + + integer(kind=int64) function get_arr_size(obj) + class(mp_arr_type) :: obj + get_arr_size = size(obj%values) + end function + + integer(kind=int64) function get_map_size(obj) + class(mp_map_type) :: obj + get_map_size = obj%ne + end function + + integer(kind=int64) function get_ext_size(obj) + class(mp_ext_type) :: obj + get_ext_size = size(obj%values) + end function +end module diff --git a/src/share/runSnow17.f90 b/src/share/runSnow17.f90 index 8f0e86c..16ab3b8 100644 --- a/src/share/runSnow17.f90 +++ b/src/share/runSnow17.f90 @@ -8,6 +8,9 @@ module runModule use runInfoType use forcingType use modelVarType + use snow_log_module + use messagepack + use iso_fortran_env implicit none @@ -17,6 +20,7 @@ module runModule type(parameters_type) :: parameters type(forcing_type) :: forcing type(modelvar_type) :: modelvar + byte, dimension(:), allocatable :: serialization_buffer end type snow17_type contains @@ -245,7 +249,155 @@ SUBROUTINE cleanup(model) close(model%runinfo%state_fileunits(nh)) end do #endif - + !Free up serialization buffer memory + if(allocated(model%serialization_buffer)) then + deallocate(model%serialization_buffer) + end if + end subroutine cleanup -end module runModule + SUBROUTINE new_serialization_request (model, exec_status) + type(snow17_type), intent(inout) :: model + integer(kind=int64) :: nh !counter for HRUs + real, dimension(:), allocatable :: cs_per_hru + class(msgpack), allocatable :: mp + class(mp_arr_type), allocatable :: mp_sub_arr + class(mp_arr_type), allocatable :: mp_state_arr + class(mp_arr_type), allocatable :: mp_cs_arr + byte, dimension(:), allocatable :: serialization_buffer + integer(kind=int64), intent(out) :: exec_status + + mp = msgpack() + mp_cs_arr = mp_arr_type(model%runinfo%n_hrus) + do nh=1, model%runinfo%n_hrus + cs_per_hru = model%modelvar%cs(:,nh) + mp_sub_arr = mp_arr_type(19) + mp_sub_arr = transfer_values_to_mp(cs_per_hru) + mp_cs_arr%values(nh)%obj = mp_sub_arr + end do + + !Add the time information and the state variables by HRU to the main mp array. + mp_state_arr = mp_arr_type(6) + mp_state_arr%values(1)%obj = mp_int_type(model%runinfo%curr_yr) !curr_yr + mp_state_arr%values(2)%obj = mp_int_type(model%runinfo%curr_mo) !curr_mo + mp_state_arr%values(3)%obj = mp_int_type(model%runinfo%curr_dy) !curr_dy + mp_state_arr%values(4)%obj = mp_int_type(model%runinfo%curr_hr) !curr_hr + mp_state_arr%values(5)%obj = transfer_values_to_mp(model%modelvar%tprev) + mp_state_arr%values(6)%obj = mp_cs_arr + + ! pack the data + call mp%pack_alloc(mp_state_arr, serialization_buffer) + if (mp%failed()) then + call write_log("Serialization using messagepack failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + else + exec_status = 0 + model%serialization_buffer = serialization_buffer + call write_log("Serialization using messagepack successful!", LOG_LEVEL_DEBUG) + end if + END SUBROUTINE new_serialization_request + + SUBROUTINE deserialize_mp_buffer (model, serialized_data) + type(snow17_type), intent(inout) :: model + integer , intent(in) :: serialized_data(:) + byte, allocatable :: serialized_data_1b(:) + class(msgpack), allocatable :: mp + class(mp_value_type), allocatable :: mpv + class(mp_arr_type), allocatable :: arr + class(mp_arr_type), allocatable :: arr_tprev_hrus + class(mp_arr_type), allocatable :: arr_cs_hrus + class(mp_arr_type), allocatable :: arr_state + integer(kind=int64) :: nh, yr, mo, dd, hr + logical :: status + + mp = msgpack() + !convert integer(4) to integer(1) for messagepack + allocate(serialized_data_1b(size(serialized_data, 1, int64)*4_int64)) + serialized_data_1b = transfer(serialized_data, serialized_data_1b) + call mp%unpack(serialized_data_1b, mpv) + if (is_arr(mpv)) then + call get_arr_ref(mpv, arr_state, status) + if (status) then + !Update the start and current time for the runInfo. + call get_int(arr_state%values(1)%obj, yr, status) + model%runinfo%curr_yr = yr + call get_int(arr_state%values(2)%obj, mo, status) + model%runinfo%curr_mo = mo + call get_int(arr_state%values(3)%obj, dd, status) + model%runinfo%curr_dy = dd + call get_int(arr_state%values(4)%obj, hr, status) + model%runinfo%curr_hr = hr + + call get_arr_ref(arr_state%values(5)%obj,arr_tprev_hrus,status) + if(status) then + !The number of elements in the serialized HRU data array for tprev is expected to match the + !number of HRUs. Check here and stop if they are not equal. + if (arr_tprev_hrus%numelements() .NE. model%runinfo%n_hrus) then + call write_log("The serialized data for model variable tprev does not contain state information for all HRUs. Please check inputs", LOG_LEVEL_FATAL) + stop + else + model%modelvar%tprev = transfer_values_from_mp(arr_tprev_hrus) + end if + else + call write_log("Deserializing data for model variable tprev failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + end if + + call get_arr_ref(arr_state%values(6)%obj,arr_cs_hrus,status) + if(status) then + !The number of elements in the serialized HRU data array for cs is expected to match the + !number of HRUs. Check here and stop if they are not equal. + if (arr_cs_hrus%numelements() .NE. model%runinfo%n_hrus) then + call write_log("The serialized data model variable cs does not contain state information for all HRUs. Please check inputs", LOG_LEVEL_FATAL) + stop + else + do nh=1, model%runinfo%n_hrus + call get_arr_ref(arr_cs_hrus%values(nh)%obj,arr,status) + if (status) then + model%modelvar%cs(:,nh) = transfer_values_from_mp(arr) + else + call write_log("Serialization using messagepack (HRU internal array) failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + end if + end do + end if + else + call write_log("Deserializing data for model variable cs failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + end if + else + call write_log("Getting an array reference to deserialized data failed! Error: " // mp%error_message, LOG_LEVEL_FATAL) + end if + else + call write_log("Deserialized data structure is not a messagepack array. Error: " // mp%error_message, LOG_LEVEL_FATAL) + end if + deallocate (mpv) + deallocate (serialized_data_1b) + + END SUBROUTINE deserialize_mp_buffer + + FUNCTION transfer_values_to_mp (src) RESULT (dest) + + real, allocatable, dimension(:), intent(in) :: src + class(mp_arr_type), allocatable :: dest + integer(kind=int64) :: index + + do index=LBOUND(src,1), UBOUND(src,1) + dest%values(index)%obj = mp_float_type(src(index)) + end do + + END FUNCTION transfer_values_to_mp + + FUNCTION transfer_values_from_mp (src) RESULT (dest) + + class(mp_arr_type), allocatable, intent(in) :: src + real, allocatable, dimension(:) :: dest + real(kind=real64) :: deserialized_val + integer(kind=int64) :: index + logical :: status + + do index=1, src%numelements() + call get_real(src%values(index)%obj, deserialized_val, status) + dest(index) = deserialized_val + end do + + END FUNCTION transfer_values_from_mp + +end module runModule