diff --git a/INSTALL.md b/INSTALL.md index 3d47e45..eb5ebe6 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,13 +4,14 @@ This release of Noah-OWP-Modular comes with example forcing data and a namelist ## Configure -Noah-OWP-Modular presently requires only one external library: [NetCDF](https://www.unidata.ucar.edu/software/netcdf/). You can install NetCDF using the link or through a package manager such as [Brew](https://brew.sh/). Once NetCDF is installed, you can configure the model. The first step is to set up a configuration file. There are currently 4 build options in the `config` directory: +Noah-OWP-Modular presently requires only one external library: [NetCDF](https://www.unidata.ucar.edu/software/netcdf/). You can install NetCDF using the link or through a package manager such as [Brew](https://brew.sh/). Once NetCDF is installed, you can configure the model. The first step is to set up a configuration file. There are currently 6 build options in the `config` directory: - `user_build_options.cheyenne`: Cheyenne supercomputer - `user_build_options.pgf90.linux`: Linux with pgf90 compiler, NetCDF installed via source (usr/local) - `user_build_options.macos.gfortran`: MacOS with gfortran compiler, NetCDF installed via source (opt/local) - `user_build_options.bigsur.gfortran`: MacOS Big Sur with gfortran compiler, NetCDF 4.8.0 installed via Brew (** this is the current tesiting environment **) - `user_build_options.gfortran.linux`: Linux with gfortran compiler, NetCDF installed via module. The $NETCDF environmental variable is defined, such as NOAA Hera. +- 'user_build_options.gfortran.ubuntu': Ubuntu with gfortran compiler, NetCDF installed from package If your system does not match one of the above options, you'll need to edit one of the files or create your own. If you do the latter, you'll need to add another option to the `configure` Perl script. diff --git a/bmi/bmi_noahowp.f90 b/bmi/bmi_noahowp.f90 index 7e4c3ec..bc2bac7 100644 --- a/bmi/bmi_noahowp.f90 +++ b/bmi/bmi_noahowp.f90 @@ -620,6 +620,10 @@ function noahowp_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('ACSNOM', 'AXAJ', 'BEXP', 'BXAJ', 'CMC', 'CWP', 'DKSAT', & @@ -634,6 +638,18 @@ function noahowp_var_type(this, name, type) result (bmi_status) case('ISNOW') type = "integer" 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 @@ -875,20 +891,37 @@ function noahowp_var_nbytes(this, name, nbytes) result (bmi_status) 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 (grid .eq. 0) then - nbytes = item_size - bmi_status = BMI_SUCCESS - else 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("bmi:noahowp_var_nbytes: invalid var " // name // ". nbytes value set to '-1'", LOG_LEVEL_WARNING) + s1 = this%get_var_grid(name, grid) + s2 = this%get_grid_size(grid, grid_size) + s3 = this%get_var_itemsize(name, item_size) + + if (grid .eq. 0) then + nbytes = item_size + bmi_status = BMI_SUCCESS + else 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("bmi:noahowp_var_nbytes: invalid var " // name // ". nbytes value set to '-1'", LOG_LEVEL_WARNING) + end if end if end function noahowp_var_nbytes @@ -921,6 +954,14 @@ function noahowp_get_int(this, name, dest) result (bmi_status) case("ISNOW") dest(:) = this%model%water%ISNOW 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 @@ -1125,9 +1166,12 @@ function noahowp_get_ptr_int(this, name, dest_ptr) result (bmi_status) integer :: n_elements select case(name) - case default - bmi_status = BMI_FAILURE - call write_log("bmi:noahowp_get_ptr_int: invalid var " // name, LOG_LEVEL_WARNING) + case("serialization_state") + dest_ptr = this%model%serialization_buffer + bmi_status = BMI_SUCCESS + case default + bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_ptr_int: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_get_ptr_int @@ -1237,6 +1281,7 @@ function noahowp_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 ================= @@ -1244,7 +1289,24 @@ function noahowp_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("bmi:noahowp_set_int: invalid var " // name, LOG_LEVEL_WARNING) end select diff --git a/run/Makefile b/run/Makefile index 63efc44..d76d95b 100644 --- a/run/Makefile +++ b/run/Makefile @@ -41,6 +41,11 @@ OBJS = \ ../src/EnergyModule.o \ ../src/UtilitiesModule.o \ ../src/DateTimeUtilsModule.o \ + ../src/byte_utilities.o \ + ../src/messagepack_value.o \ + ../src/messagepack_user.o \ + ../src/messagepack.o \ + ../src/StateSerialization.o \ ../src/RunModule.o \ ../driver/OutputModule.o \ ../driver/NoahModularDriver.o \ diff --git a/src/Makefile b/src/Makefile index e864139..ff444ae 100644 --- a/src/Makefile +++ b/src/Makefile @@ -41,6 +41,11 @@ OBJS = noahowpLogger.o \ EnergyModule.o \ UtilitiesModule.o \ DateTimeUtilsModule.o \ + byte_utilities.o \ + messagepack_value.o \ + messagepack_user.o \ + messagepack.o \ + StateSerialization.o \ RunModule.o all: $(OBJS) @@ -107,8 +112,13 @@ EnergyModule.o: OptionsType.o LevelsType.o DomainType.o ParametersType.o EnergyT ForcingType.o WaterType.o ThermalPropertiesModule.o ShortwaveRadiationModule.o \ PrecipHeatModule.o EtFluxModule.o SnowSoilTempModule.o UtilitiesModule.o: DomainType.o ForcingType.o EnergyType.o +messagepack_value.o: byte_utilities.o +messagepack_user.o: byte_utilities.o messagepack_value.o +messagepack.o: byte_utilities.o messagepack_value.o messagepack_user.o +StateSerialization.o: DomainType.o ParametersType.o EnergyType.o \ + ForcingType.o WaterType.o messagepack.o RunModule.o: OptionsType.o LevelsType.o DomainType.o ParametersType.o EnergyType.o \ ForcingType.o WaterType.o NamelistRead.o ../driver/AsciiReadModule.o \ ../driver/OutputModule.o UtilitiesModule.o ForcingModule.o InterceptionModule.o \ - EnergyModule.o WaterModule.o DateTimeUtilsModule.o + EnergyModule.o WaterModule.o DateTimeUtilsModule.o messagepack.o StateSerialization.o diff --git a/src/RunModule.f90 b/src/RunModule.f90 index cb357b8..9d5d324 100644 --- a/src/RunModule.f90 +++ b/src/RunModule.f90 @@ -18,6 +18,10 @@ module RunModule use EnergyModule use WaterModule use DateTimeUtilsModule + use noahowp_log_module + use StateSerialization + use messagepack + use iso_fortran_env implicit none type :: noahowp_type @@ -29,6 +33,7 @@ module RunModule type(water_type) :: water type(forcing_type) :: forcing type(energy_type) :: energy + byte, dimension(:), allocatable :: serialization_buffer end type noahowp_type contains @@ -237,7 +242,12 @@ SUBROUTINE cleanup(model) #ifndef NGEN_OUTPUT_ACTIVE call finalize_output() #endif - + !Free up serialization buffer memory + if(allocated(model%serialization_buffer)) then + deallocate(model%serialization_buffer) + end if + + END SUBROUTINE cleanup !== Move the model ahead one time step ================================================================ @@ -327,4 +337,100 @@ SUBROUTINE solve_noahowp(model) end associate ! terminate associate block END SUBROUTINE solve_noahowp + SUBROUTINE new_serialization_request (model, exec_status) + type(noahowp_type), intent(inout) :: model + class(msgpack), allocatable :: mp + class(mp_arr_type), allocatable :: mp_sub_arr + class(mp_arr_type), allocatable :: mp_arr + byte, dimension(:), allocatable :: serialization_buffer + integer(kind=int64), intent(out) :: exec_status + + mp = msgpack() + mp_arr = mp_arr_type(5) !forcing, domain, energy,water, parameters + + call forcing_serialization(model%forcing,mp_sub_arr) + mp_arr%values(1)%obj = mp_sub_arr !forcing + deallocate(mp_sub_arr) + + call energy_serialization(model%energy,mp_sub_arr) + mp_arr%values(2)%obj = mp_sub_arr !energy + deallocate(mp_sub_arr) + + call domain_serialization(model%domain,mp_sub_arr) + mp_arr%values(3)%obj = mp_sub_arr !domain + deallocate(mp_sub_arr) + + call water_serialization(model%water,mp_sub_arr) + mp_arr%values(4)%obj = mp_sub_arr !water + deallocate(mp_sub_arr) + + call parameters_serialization(model%parameters,mp_sub_arr) + mp_arr%values(5)%obj = mp_sub_arr !parameters + deallocate(mp_sub_arr) + + ! pack the data + call mp%pack_alloc(mp_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_INFO) + end if + END SUBROUTINE new_serialization_request + + SUBROUTINE deserialize_mp_buffer (model, serialized_data) + type(noahowp_type), intent(inout) :: model + integer , intent(in) :: serialized_data(:) + byte, allocatable :: serialized_data_1b(:) + class(mp_value_type), allocatable :: mpv + class(msgpack), allocatable :: mp + class(mp_arr_type), allocatable :: arr_all + class(mp_arr_type), allocatable :: arr + logical :: error, status + integer(kind=int64) :: index + + 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_all, status) + if (status) then + !The number of elements in the serialized data array is expected to be 5. Check here and stop if they are not equal. + if (mpv%numelements() .NE. 5) then + call write_log("The serialized data does not contain all state information. Please check inputs", LOG_LEVEL_FATAL) + stop + end if + + do index=1,5 + call get_arr_ref(arr_all%values(index)%obj,arr,status) + if(status) then + select case(index) + case(1) + call forcing_deserialization (arr, model%forcing) + case(2) + call energy_deserialization (arr, model%energy) + case(3) + call domain_deserialization (arr, model%domain) + case(4) + call water_deserialization (arr, model%water) + case(5) + call parameters_deserialization (arr, model%parameters) + end select + else + call write_log("Deserialization using messagepack (internal array) failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + end if + end do + else + call write_log("Deserialization using messagepack (external array) failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + end if + end if + deallocate (mpv) + deallocate (serialized_data_1b) + + END SUBROUTINE deserialize_mp_buffer + end module RunModule diff --git a/src/StateSerialization.f90 b/src/StateSerialization.f90 new file mode 100644 index 0000000..ea4a092 --- /dev/null +++ b/src/StateSerialization.f90 @@ -0,0 +1,887 @@ +module StateSerialization + + use DomainType + use ParametersType + use WaterType + use EnergyType + use ForcingType + use messagepack + use iso_fortran_env + + implicit none + +contains + +SUBROUTINE forcing_serialization (forcing, mp_arr) + type(forcing_type), intent(in) :: forcing + class(mp_arr_type), allocatable, intent(out) :: mp_arr + mp_arr = mp_arr_type(22) + mp_arr%values(1)%obj = mp_float_type(forcing%UU) !UU + mp_arr%values(2)%obj = mp_float_type(forcing%VV) !VV + mp_arr%values(3)%obj = mp_float_type(forcing%SFCTMP) !SFCTMP + mp_arr%values(4)%obj = mp_float_type(forcing%Q2) !Q2 + mp_arr%values(5)%obj = mp_float_type(forcing%SFCPRS) !SFCPRS + mp_arr%values(6)%obj = mp_float_type(forcing%SOLDN) !SOLDN + mp_arr%values(7)%obj = mp_float_type(forcing%LWDN) !LWDN + mp_arr%values(8)%obj = mp_float_type(forcing%JULIAN) !JULIAN, out + mp_arr%values(9)%obj = mp_float_type(forcing%THAIR) !THAIR, out + mp_arr%values(10)%obj = mp_float_type(forcing%QAIR) !QAIR, out + mp_arr%values(11)%obj = mp_float_type(forcing%EAIR) !EAIR, out + mp_arr%values(12)%obj = mp_float_type(forcing%RHOAIR) !RHOAIR, out + mp_arr%values(13)%obj = mp_float_type(forcing%O2PP) !O2PP + mp_arr%values(14)%obj = mp_float_type(forcing%CO2PP) !CO2PP + mp_arr%values(15)%obj = mp_float_type(forcing%SWDOWN) !SWDOWN, out + mp_arr%values(16)%obj = mp_float_type(forcing%PRCP) !PRCP + mp_arr%values(17)%obj = mp_float_type(forcing%PRCPNONC) !PRCPNONC + mp_arr%values(18)%obj = mp_float_type(forcing%FPICE) !FPICE, out + mp_arr%values(19)%obj = mp_float_type(forcing%UR) !UR, out + mp_arr%values(20)%obj = mp_int_type(forcing%YEARLEN) !YEARLEN, out + mp_arr%values(21)%obj = transfer_values_to_mp(forcing%SOLAD) !SOLAD + mp_arr%values(22)%obj = transfer_values_to_mp(forcing%SOLAI) !SOLAI + +END SUBROUTINE forcing_serialization + +SUBROUTINE forcing_deserialization (mp_arr, forcing) + class(mp_arr_type), allocatable, intent(in) :: mp_arr + type(forcing_type), intent(inout) :: forcing + real(kind=real64) :: deserialized_val + integer(kind=int64) :: deserialized_int_val + class(mp_arr_type), allocatable :: mp_sub_arr + logical :: status + integer(kind=int64) :: index, sub_index + + do index=1, mp_arr%numelements() + if (index .LE. 19) then + call get_real(mp_arr%values(index)%obj, deserialized_val, status) + else if (index == 20) then + call get_int(mp_arr%values(index)%obj, deserialized_int_val, status) + else if (index .GE. 21) then + if (is_arr(mp_arr%values(index)%obj)) then + call get_arr_ref(mp_arr%values(index)%obj, mp_sub_arr, status) + end if + end if + select case(index) + case(1) + forcing%UU = deserialized_val + case(2) + forcing%VV = deserialized_val + case(3) + forcing%SFCTMP = deserialized_val + case(4) + forcing%Q2 = deserialized_val + case(5) + forcing%SFCPRS = deserialized_val + case(6) + forcing%SOLDN = deserialized_val + case(7) + forcing%LWDN = deserialized_val + case(8) + forcing%JULIAN = deserialized_val + case(9) + forcing%THAIR = deserialized_val + case(10) + forcing%QAIR = deserialized_val + case(11) + forcing%EAIR = deserialized_val + case(12) + forcing%RHOAIR = deserialized_val + case(13) + forcing%O2PP = deserialized_val + case(14) + forcing%CO2PP = deserialized_val + case(15) + forcing%SWDOWN = deserialized_val + case(16) + forcing%PRCP = deserialized_val + case(17) + forcing%PRCPNONC = deserialized_val + case(18) + forcing%FPICE = deserialized_val + case(19) + forcing%UR = deserialized_val + case(20) + forcing%YEARLEN = deserialized_int_val + case(21) + forcing%SOLAD = transfer_values_from_mp(mp_sub_arr) + case(22) + forcing%SOLAI = transfer_values_from_mp(mp_sub_arr) + end select + end do +END SUBROUTINE forcing_deserialization + + +SUBROUTINE domain_serialization (domain, mp_arr) + type(domain_type), intent(in) :: domain + class(mp_arr_type), allocatable, intent(out) :: mp_arr + + mp_arr = mp_arr_type(6) + mp_arr%values(1)%obj = mp_float_type(domain%curr_datetime) !curr_datetime + mp_arr%values(2)%obj = mp_float_type(domain%time_dbl) !time_dbl + mp_arr%values(3)%obj = mp_int_type(domain%ITIME) !ITIME + mp_arr%values(4)%obj = mp_str_type(domain%nowdate) !nowdate + mp_arr%values(5)%obj = transfer_values_to_mp(domain%DZSNSO) + mp_arr%values(6)%obj = transfer_values_to_mp(domain%ZSNSO) + +END SUBROUTINE domain_serialization + +SUBROUTINE domain_deserialization (mp_arr, domain) + class(mp_arr_type), allocatable, intent(in) :: mp_arr + type(domain_type), intent(inout) :: domain + real(kind=real64) :: deserialized_val + integer(kind=int64) :: deserialized_int_val + character(:), allocatable :: deserialized_str_val + class(mp_arr_type), allocatable :: mp_sub_arr + logical :: status + integer(kind=int64) :: index, sub_index + + do index=1, mp_arr%numelements() + if (index .LE. 2) then + call get_real(mp_arr%values(index)%obj, deserialized_val, status) + else if (index == 3) then + call get_int(mp_arr%values(index)%obj, deserialized_int_val, status) + else if (index == 4) then + call get_str(mp_arr%values(index)%obj, deserialized_str_val, status) + else if (index .GE. 5) then + if (is_arr(mp_arr%values(index)%obj)) then + call get_arr_ref(mp_arr%values(index)%obj, mp_sub_arr, status) + end if + end if + select case(index) + case(1) + domain%curr_datetime = deserialized_val + case(2) + domain%time_dbl = deserialized_val + case(3) + domain%ITIME = deserialized_int_val + case(4) + domain%nowdate = deserialized_str_val + case(5) + domain%DZSNSO = transfer_values_from_mp(mp_sub_arr) + case(6) + domain%ZSNSO = transfer_values_from_mp(mp_sub_arr) + end select + end do +END SUBROUTINE domain_deserialization + +SUBROUTINE energy_serialization (energy, mp_arr) + type(energy_type), intent(in) :: energy + class(mp_arr_type), allocatable, intent(out) :: mp_arr + + mp_arr = mp_arr_type(125) + mp_arr%values(1)%obj = mp_float_type(energy%cosz) !cosz + mp_arr%values(2)%obj = mp_float_type(energy%cosz_horiz) !cosz_horiz + mp_arr%values(3)%obj = mp_float_type(energy%TAH) !TAH + mp_arr%values(4)%obj = mp_float_type(energy%EAH) !EAH + mp_arr%values(5)%obj = mp_float_type(energy%IGS) !IGS + mp_arr%values(6)%obj = mp_float_type(energy%TAUXV) !TAUXV + mp_arr%values(7)%obj = mp_float_type(energy%TAUYV) !TAUYV + mp_arr%values(8)%obj = mp_float_type(energy%IRC) !IRC + mp_arr%values(9)%obj = mp_float_type(energy%SHC) !SHC + mp_arr%values(10)%obj = mp_float_type(energy%IRG) !IRG + mp_arr%values(11)%obj = mp_float_type(energy%SHG) !SHG + mp_arr%values(12)%obj = mp_float_type(energy%EVG) !EVG + mp_arr%values(13)%obj = mp_float_type(energy%EVC) !EVC + mp_arr%values(14)%obj = mp_float_type(energy%TR) !TR + mp_arr%values(15)%obj = mp_float_type(energy%GHV) !GHV + mp_arr%values(16)%obj = mp_float_type(energy%PSNSUN) !PSNSUN + mp_arr%values(17)%obj = mp_float_type(energy%PSNSHA) !PSNSHA + mp_arr%values(18)%obj = mp_float_type(energy%T2MV) !T2MV + mp_arr%values(19)%obj = mp_float_type(energy%Q2V) !Q2V + mp_arr%values(20)%obj = mp_float_type(energy%CHV) !CHV + mp_arr%values(21)%obj = mp_float_type(energy%CHLEAF) !CHLEAF + mp_arr%values(22)%obj = mp_float_type(energy%CHUC) !CHUC + mp_arr%values(23)%obj = mp_float_type(energy%CHV2) !CHV2 + mp_arr%values(24)%obj = mp_float_type(energy%RB) !RB + mp_arr%values(25)%obj = mp_float_type(energy%Z0MG) !Z0MG + mp_arr%values(26)%obj = mp_float_type(energy%Z0M) !Z0M + mp_arr%values(27)%obj = mp_float_type(energy%ZPD) !ZPD + mp_arr%values(28)%obj = mp_float_type(energy%ZLVL) !ZLVL + mp_arr%values(29)%obj = mp_float_type(energy%EMG) !EMG + mp_arr%values(30)%obj = mp_float_type(energy%RSURF) !RSURF + mp_arr%values(31)%obj = mp_float_type(energy%RHSUR) !RHSUR + mp_arr%values(32)%obj = mp_float_type(energy%LATHEAV) !LATHEAV + mp_arr%values(34)%obj = mp_float_type(energy%GAMMAV) !GAMMAV + mp_arr%values(35)%obj = mp_float_type(energy%LATHEAG) !LATHEAG + mp_arr%values(36)%obj = mp_float_type(energy%GAMMAG) !GAMMAG + mp_arr%values(37)%obj = mp_float_type(energy%TGB) !TGB + mp_arr%values(38)%obj = mp_float_type(energy%CMB) !CMB + mp_arr%values(39)%obj = mp_float_type(energy%CHB) !CHB + mp_arr%values(40)%obj = mp_float_type(energy%Z0WRF) !Z0WRF + mp_arr%values(41)%obj = mp_float_type(energy%RSSUN) !RSSUN + mp_arr%values(42)%obj = mp_float_type(energy%T2M) !T2M + mp_arr%values(43)%obj = mp_float_type(energy%Q1) !Q1 + mp_arr%values(44)%obj = mp_float_type(energy%Q2E) !Q2E + mp_arr%values(45)%obj = mp_float_type(energy%FGEV) !FGEV + mp_arr%values(46)%obj = mp_float_type(energy%TS) !TS + mp_arr%values(47)%obj = mp_float_type(energy%TAUY) !TAUY + mp_arr%values(48)%obj = mp_float_type(energy%GH) !GH + mp_arr%values(59)%obj = mp_float_type(energy%SSOIL) !SSOIL + mp_arr%values(50)%obj = mp_float_type(energy%TGV) !TGV + mp_arr%values(51)%obj = mp_float_type(energy%FCEV) !FCEV + mp_arr%values(52)%obj = mp_float_type(energy%CM) !CM + mp_arr%values(53)%obj = mp_float_type(energy%FIRA) !FIRA + mp_arr%values(54)%obj = mp_float_type(energy%RSSHA) !RSSHA + mp_arr%values(55)%obj = mp_float_type(energy%TG) !TG + mp_arr%values(57)%obj = mp_float_type(energy%CH) !CH + mp_arr%values(56)%obj = mp_float_type(energy%FCTR) !FCTR + mp_arr%values(57)%obj = mp_float_type(energy%PAH) !PAH + mp_arr%values(58)%obj = mp_float_type(energy%TAUX) !TAUX + mp_arr%values(59)%obj = mp_float_type(energy%FSH) !FSH + mp_arr%values(60)%obj = mp_float_type(energy%EMISSI) !EMISSI + mp_arr%values(61)%obj = mp_float_type(energy%TRAD) !TRAD + mp_arr%values(62)%obj = mp_float_type(energy%APAR) !APAR + mp_arr%values(63)%obj = mp_float_type(energy%PSN) !PSN + mp_arr%values(64)%obj = mp_float_type(energy%LH) !LH + mp_arr%values(65)%obj = mp_float_type(energy%TGS) !TGS + mp_arr%values(66)%obj = mp_float_type(energy%PAHV) !PAHV + mp_arr%values(67)%obj = mp_float_type(energy%PAHG) !PAHG + mp_arr%values(68)%obj = mp_float_type(energy%PAHB) !PAHB + mp_arr%values(69)%obj = mp_float_type(energy%FSHA) !FSHA + mp_arr%values(70)%obj = mp_float_type(energy%LAISUN) !LAISUN + mp_arr%values(71)%obj = mp_float_type(energy%LAISHA) !LAISHA + mp_arr%values(72)%obj = mp_float_type(energy%BGAP) !BGAP + mp_arr%values(73)%obj = mp_float_type(energy%WGAP) !WGAP + mp_arr%values(74)%obj = mp_float_type(energy%FSUN) !FSUN + mp_arr%values(75)%obj = mp_float_type(energy%TAUSS) !TAUSS + mp_arr%values(76)%obj = mp_float_type(energy%FAGE) !FAGE + mp_arr%values(77)%obj = mp_float_type(energy%ALB) !ALB + mp_arr%values(78)%obj = mp_float_type(energy%ALBOLD) !ALBOLD + mp_arr%values(79)%obj = mp_float_type(energy%SAG) !SAG + mp_arr%values(80)%obj = mp_float_type(energy%SAV) !SAV + mp_arr%values(81)%obj = mp_float_type(energy%FSA) !FSA + mp_arr%values(82)%obj = mp_float_type(energy%PARSUN) !PARSUN + mp_arr%values(83)%obj = mp_float_type(energy%PARSHA) !PARSHA + mp_arr%values(84)%obj = mp_float_type(energy%FSR) !FSR + mp_arr%values(85)%obj = mp_float_type(energy%FSRV) !FSRV + mp_arr%values(86)%obj = mp_float_type(energy%FSRG) !FSRG + mp_arr%values(87)%obj = mp_float_type(energy%QSFC) !QSFC + mp_arr%values(88)%obj = mp_float_type(energy%TV) !TV + mp_arr%values(89)%obj = mp_float_type(energy%CAH2) !CAH2 + mp_arr%values(90)%obj = mp_float_type(energy%IRB) !IRB + mp_arr%values(91)%obj = mp_float_type(energy%SHB) !SHB + mp_arr%values(92)%obj = mp_float_type(energy%EVB) !EVB + mp_arr%values(93)%obj = mp_float_type(energy%GHB) !GHB + mp_arr%values(94)%obj = mp_float_type(energy%TAUXB) !TAUXB + mp_arr%values(95)%obj = mp_float_type(energy%TAUYB) !TAUYB + mp_arr%values(96)%obj = mp_float_type(energy%EHB2) !EHB2 + mp_arr%values(97)%obj = mp_float_type(energy%T2MB) !T2MB + mp_arr%values(98)%obj = mp_float_type(energy%Q2B) !Q2B + mp_arr%values(99)%obj = mp_float_type(energy%QMELT) !QMELT + mp_arr%values(100)%obj = mp_float_type(energy%SNOWT_AVG) !SNOWT_AVG , could be realMissing + mp_arr%values(101)%obj = mp_bool_type(energy%frozen_ground) !frozen_ground + mp_arr%values(102)%obj = mp_bool_type(energy%frozen_canopy) !frozen_canopy + mp_arr%values(103)%obj = transfer_values_to_mp(energy%FTDI) !FTDI array (1:2) + mp_arr%values(104)%obj = transfer_values_to_mp(energy%FREVD) !FREVD array (1:2) + mp_arr%values(105)%obj = transfer_values_to_mp(energy%FREGD) !FREGD array (1:2) + mp_arr%values(106)%obj = transfer_values_to_mp(energy%FREVI) !FREVI array (1:2) + mp_arr%values(107)%obj = transfer_values_to_mp(energy%FREGI) !FREGI array (1:2) + mp_arr%values(108)%obj = transfer_values_to_mp(energy%STC) !STC array + mp_arr%values(109)%obj = transfer_values_to_mp(energy%HCPCT ) !HCPCT array (-levels%NSNOW+1:levels%NSOIL) + mp_arr%values(110)%obj = transfer_values_to_mp(energy%DF ) !DF array (-levels%NSNOW+1:levels%NSOIL) + mp_arr%values(111)%obj = transfer_values_to_mp(energy%FACT ) !FACT array (-levels%NSNOW+1:levels%NSOIL) + mp_arr%values(112)%obj = transfer_values_to_mp(energy%ALBD) !ALBD array (1:parameters%NBAND) + mp_arr%values(113)%obj = transfer_values_to_mp(energy%ALBI) !ALBI array (1:parameters%NBAND) + mp_arr%values(114)%obj = transfer_values_to_mp(energy%ALBGRD) !ALBGRD array (1:parameters%NBAND) + mp_arr%values(115)%obj = transfer_values_to_mp(energy%ALBGRI) !ALBGRI array (1:parameters%NBAND) + mp_arr%values(116)%obj = transfer_values_to_mp(energy%ALBSND) !ALBSND array (1:parameters%NBAND) + mp_arr%values(117)%obj = transfer_values_to_mp(energy%ALBSNI) !ALBSNI array (1:parameters%NBAND) + mp_arr%values(118)%obj = transfer_values_to_mp(energy%FABD) !FABD array (1:parameters%NBAND) + mp_arr%values(119)%obj = transfer_values_to_mp(energy%FABI) !FABI array (1:parameters%NBAND) + mp_arr%values(120)%obj = transfer_values_to_mp(energy%FTDD) !FTDD array (1:parameters%NBAND) + mp_arr%values(121)%obj = transfer_values_to_mp(energy%FTID) !FTID array (1:parameters%NBAND) + mp_arr%values(122)%obj = transfer_values_to_mp(energy%FTII) !FTII array (1:parameters%NBAND) + mp_arr%values(123)%obj = transfer_values_to_mp(energy%RHO) !RHO array (1:parameters%NBAND) + mp_arr%values(124)%obj = transfer_values_to_mp(energy%TAU) !TAU array (1:parameters%NBAND) + mp_arr%values(125)%obj = transfer_values_to_mp_int(energy%IMELT) !IMELT array (-levels%NSNOW+1:levels%NSOIL) + +END SUBROUTINE energy_serialization + +SUBROUTINE energy_deserialization (mp_arr, energy) + class(mp_arr_type), allocatable, intent(in) :: mp_arr + type(energy_type), intent(inout) :: energy + real(kind=real64) :: deserialized_val + integer(kind=int64) :: deserialized_int_val + class(mp_arr_type), allocatable :: mp_sub_arr + logical :: status, is_true_val + integer(kind=int64) :: index, sub_index + + do index=1, mp_arr%numelements() + if (index .LE. 100) then + call get_real(mp_arr%values(index)%obj, deserialized_val, status) + else if (index == 101 .OR. index == 102) then + call get_bool(mp_arr%values(index)%obj, is_true_val, status) + else if ((index .GE. 103)) then + if (is_arr(mp_arr%values(index)%obj)) then + call get_arr_ref(mp_arr%values(index)%obj, mp_sub_arr, status) + end if + end if + select case(index) + case(1) + energy%cosz = deserialized_val + case(2) + energy%cosz_horiz = deserialized_val + case(3) + energy%TAH = deserialized_val + case(4) + energy%EAH = deserialized_val + case(5) + energy%IGS = deserialized_val + case(6) + energy%TAUXV = deserialized_val + case(7) + energy%TAUYV = deserialized_val + case(8) + energy%IRC = deserialized_val + case(9) + energy%SHC = deserialized_val + case(10) + energy%IRG = deserialized_val + case(11) + energy%SHG = deserialized_val + case(12) + energy%EVG = deserialized_val + case(13) + energy%EVC = deserialized_val + case(14) + energy%TR = deserialized_val + case(15) + energy%PSNSUN = deserialized_val + case(17) + energy%PSNSHA = deserialized_val + case(18) + energy%T2MV = deserialized_val + case(19) + energy%Q2V = deserialized_val + case(20) + energy%CHV = deserialized_val + case(21) + energy%CHLEAF = deserialized_val + case(22) + energy%CHUC = deserialized_val + case(23) + energy%CHV2 = deserialized_val + case(24) + energy%RB = deserialized_val + case(25) + energy%Z0MG = deserialized_val + case(26) + energy%Z0M = deserialized_val + case(27) + energy%ZPD = deserialized_val + case(28) + energy%ZLVL = deserialized_val + case(29) + energy%EMG = deserialized_val + case(30) + energy%RSURF = deserialized_val + case(31) + energy%RHSUR = deserialized_val + case(32) + energy%LATHEAV = deserialized_val + case(33) + energy%GAMMAV = deserialized_val + case(34) + energy%LATHEAG = deserialized_val + case(35) + energy%GAMMAG = deserialized_val + case(36) + energy%TGB = deserialized_val + case(37) + energy%CMB = deserialized_val + case(38) + energy%CHB = deserialized_val + case(39) + energy%Z0WRF = deserialized_val + case(40) + energy%RSSUN = deserialized_val + case(41) + energy%T2M = deserialized_val + case(42) + energy%Q1 = deserialized_val + case(43) + energy%Q2E = deserialized_val + case(44) + energy%FGEV = deserialized_val + case(45) + energy%TS = deserialized_val + case(46) + energy%TAUY = deserialized_val + case(47) + energy%GH = deserialized_val + case(48) + energy%SSOIL = deserialized_val + case(49) + energy%TGV = deserialized_val + case(50) + energy%FCEV = deserialized_val + case(51) + energy%CM = deserialized_val + case(52) + energy%FIRA = deserialized_val + case(53) + energy%RSSHA = deserialized_val + case(54) + energy%TG = deserialized_val + case(55) + energy%CH = deserialized_val + case(56) + energy%FCTR = deserialized_val + case(57) + energy%PAH = deserialized_val + case(58) + energy%TAUX = deserialized_val + case(59) + energy%FSH = deserialized_val + case(60) + energy%EMISSI = deserialized_val + case(61) + energy%TRAD = deserialized_val + case(62) + energy%APAR = deserialized_val + case(63) + energy%PSN = deserialized_val + case(64) + energy%LH = deserialized_val + case(65) + energy%TGS = deserialized_val + case(66) + energy%PAHV = deserialized_val + case(67) + energy%PAHV = deserialized_val + case(68) + energy%PAHB = deserialized_val + case(69) + energy%FSHA = deserialized_val + case(70) + energy%LAISUN = deserialized_val + case(71) + energy%LAISHA = deserialized_val + case(72) + energy%BGAP = deserialized_val + case(73) + energy%WGAP = deserialized_val + case(74) + energy%FSUN = deserialized_val + case(75) + energy%TAUSS = deserialized_val + case(76) + energy%FAGE = deserialized_val + case(77) + energy%ALB = deserialized_val + case(78) + energy%ALBOLD = deserialized_val + case(79) + energy%SAG = deserialized_val + case(80) + energy%SAV = deserialized_val + case(81) + energy%FSA = deserialized_val + case(82) + energy%PARSUN = deserialized_val + case(83) + energy%PARSHA = deserialized_val + case(84) + energy%FSR = deserialized_val + case(85) + energy%FSRV = deserialized_val + case(86) + energy%FSRG = deserialized_val + case(87) + energy%QSFC = deserialized_val + case(88) + energy%TV = deserialized_val + case(89) + energy%CAH2 = deserialized_val + case(90) + energy%IRB = deserialized_val + case(91) + energy%SHB = deserialized_val + case(92) + energy%EVB = deserialized_val + case(93) + energy%GHB = deserialized_val + case(94) + energy%TAUXB = deserialized_val + case(95) + energy%TAUYB = deserialized_val + case(96) + energy%EHB2 = deserialized_val + case(97) + energy%T2MB = deserialized_val + case(98) + energy%Q2B = deserialized_val + case(99) + energy%QMELT = deserialized_val + case(100) + energy%SNOWT_AVG = deserialized_val + case(101) + energy%frozen_canopy = is_true_val + case(102) + energy%frozen_ground = is_true_val + case(103) + energy%FTDI = transfer_values_from_mp(mp_sub_arr) + case(104) + energy%FREVD = transfer_values_from_mp(mp_sub_arr) + case(105) + energy%FREGD = transfer_values_from_mp(mp_sub_arr) + case(106) + energy%FREVI = transfer_values_from_mp(mp_sub_arr) + case(107) + energy%FREGI = transfer_values_from_mp(mp_sub_arr) + case(108) + energy%STC = transfer_values_from_mp(mp_sub_arr) + case(109) + energy%HCPCT = transfer_values_from_mp(mp_sub_arr) + case(110) + energy%DF = transfer_values_from_mp(mp_sub_arr) + case(111) + energy%FACT = transfer_values_from_mp(mp_sub_arr) + case(112) + energy%ALBD = transfer_values_from_mp(mp_sub_arr) + case(113) + energy%ALBI = transfer_values_from_mp(mp_sub_arr) + case(114) + energy%ALBGRD = transfer_values_from_mp(mp_sub_arr) + case(115) + energy%ALBGRI = transfer_values_from_mp(mp_sub_arr) + case(116) + energy%ALBSND = transfer_values_from_mp(mp_sub_arr) + case(117) + energy%ALBSNI = transfer_values_from_mp(mp_sub_arr) + case(118) + energy%FABD = transfer_values_from_mp(mp_sub_arr) + case(119) + energy%FABI = transfer_values_from_mp(mp_sub_arr) + case(120) + energy%FTDD = transfer_values_from_mp(mp_sub_arr) + case(121) + energy%FTID = transfer_values_from_mp(mp_sub_arr) + case(122) + energy%FTII = transfer_values_from_mp(mp_sub_arr) + case(123) + energy%RHO = transfer_values_from_mp(mp_sub_arr) + case(124) + energy%TAU = transfer_values_from_mp(mp_sub_arr) + case(125) + energy%IMELT = transfer_values_from_mp_int(mp_sub_arr) + end select + end do +END SUBROUTINE energy_deserialization + + +SUBROUTINE water_serialization (water, mp_arr) + type(water_type), intent(in) :: water + class(mp_arr_type), allocatable, intent(out) :: mp_arr + + mp_arr = mp_arr_type(64) + mp_arr%values(1)%obj = mp_float_type(water%FP) !FP + mp_arr%values(2)%obj = mp_float_type(water%RAIN) !RAIN + mp_arr%values(3)%obj = mp_float_type(water%SNOW) !SNOW + mp_arr%values(4)%obj = mp_float_type(water%BDFALL) !BDFALL + mp_arr%values(5)%obj = mp_float_type(water%QINTR) !QINTR + mp_arr%values(6)%obj = mp_float_type(water%QDRIPR) !QDRIPR + mp_arr%values(7)%obj = mp_float_type(water%QTHROR) !QTHROR + mp_arr%values(8)%obj = mp_float_type(water%QINTS) !QINTS + mp_arr%values(9)%obj = mp_float_type(water%QDRIPS) !QDRIPS + mp_arr%values(10)%obj = mp_float_type(water%QTHROS) !QTHROS + mp_arr%values(11)%obj = mp_float_type(water%QRAIN) !QRAIN + mp_arr%values(12)%obj = mp_float_type(water%QSNOW) !QSNOW + mp_arr%values(13)%obj = mp_float_type(water%SNOWHIN) !SNOWHIN + mp_arr%values(14)%obj = mp_float_type(water%CANLIQ) !CANLIQ + mp_arr%values(15)%obj = mp_float_type(water%CANICE) !CANICE + mp_arr%values(16)%obj = mp_float_type(water%FWET) !FWET + mp_arr%values(17)%obj = mp_float_type(water%CMC) !CMC + mp_arr%values(18)%obj = mp_float_type(water%FSNO) !FSNO + mp_arr%values(19)%obj = mp_float_type(water%BDSNO) !BDSNO + mp_arr%values(20)%obj = mp_float_type(water%BTRAN) !BTRAN + mp_arr%values(21)%obj = mp_float_type(water%SNEQV) !SNEQV + mp_arr%values(22)%obj = mp_float_type(water%SNOWH) !SNOWH + mp_arr%values(23)%obj = mp_float_type(water%PONDING) !PONDING + mp_arr%values(24)%obj = mp_float_type(water%SNEQVO) !SNEQVO + mp_arr%values(25)%obj = mp_float_type(water%QVAP) !QVAP + mp_arr%values(26)%obj = mp_float_type(water%QDEW) !QDEW + mp_arr%values(27)%obj = mp_float_type(water%QSNSUB) !QSNSUB + mp_arr%values(28)%obj = mp_float_type(water%QSEVA) !QSEVA + mp_arr%values(29)%obj = mp_float_type(water%QSNFRO) !QSNFRO + mp_arr%values(30)%obj = mp_float_type(water%QSDEW) !QSDEW + mp_arr%values(31)%obj = mp_float_type(water%QINSUR) !QINSUR + mp_arr%values(32)%obj = mp_float_type(water%ACSNOM) !ACSNOM + mp_arr%values(33)%obj = mp_float_type(water%RUNSRF) !RUNSRF + mp_arr%values(34)%obj = mp_float_type(water%WSLAKE) !WSLAKE + mp_arr%values(35)%obj = mp_float_type(water%EVAPOTRANS) !EVAPOTRANS + mp_arr%values(36)%obj = mp_float_type(water%ECAN) !ECAN + mp_arr%values(37)%obj = mp_float_type(water%ETRAN) !ETRAN + mp_arr%values(38)%obj = mp_float_type(water%SNOFLOW) !SNOFLOW + mp_arr%values(39)%obj = mp_float_type(water%PONDING1) !PONDING1 + mp_arr%values(40)%obj = mp_float_type(water%PONDING2) !PONDING2 + mp_arr%values(41)%obj = mp_float_type(water%QSNBOT) !QSNBOT + mp_arr%values(42)%obj = mp_float_type(water%RUNSUB) !RUNSUB + mp_arr%values(43)%obj = mp_float_type(water%PDDUM) !PDDUM + mp_arr%values(44)%obj = mp_float_type(water%runsrf_dt) !runsrf_dt + mp_arr%values(45)%obj = mp_float_type(water%SICEMAX) !SICEMAX + mp_arr%values(46)%obj = mp_float_type(water%FCRMAX) !FCRMAX + mp_arr%values(47)%obj = mp_float_type(water%FACC) !FACC + mp_arr%values(48)%obj = mp_float_type(water%QDRAIN) !QDRAIN + mp_arr%values(49)%obj = mp_float_type(water%DEEPRECH) !DEEPRECH + mp_arr%values(50)%obj = mp_float_type(water%ZWT) !ZWT + mp_arr%values(51)%obj = mp_float_type(water%ASAT) !ASAT + mp_arr%values(52)%obj = mp_float_type(water%SMCWTD) !SMCWTD + mp_arr%values(53)%obj = mp_int_type(water%ISNOW) !ISNOW integer + mp_arr%values(54)%obj = transfer_values_to_mp(water%BTRANI ) !BTRANI array (1:levels%NSOIL) + mp_arr%values(55)%obj = transfer_values_to_mp(water%SNICEV ) !SNICEV array (-levels%NSNOW+1:0) # negative indexes + mp_arr%values(56)%obj = transfer_values_to_mp(water%EPORE ) !EPORE array (-levels%NSNOW+1:0) # negative indexes + mp_arr%values(57)%obj = transfer_values_to_mp(water%SNLIQV ) !SNLIQV array (-levels%NSNOW+1:0) # negative indexes + mp_arr%values(58)%obj = transfer_values_to_mp(water%SICE ) !SICE array (1:levels%NSOIL) + mp_arr%values(59)%obj = transfer_values_to_mp(water%SH2O ) !SH2O array (1:levels%NSOIL) + mp_arr%values(60)%obj = transfer_values_to_mp(water%SMC ) !SMC array (1:levels%NSOIL) + mp_arr%values(61)%obj = transfer_values_to_mp(water%SNICE ) !SNICE array (-levels%NSNOW+1:0) + mp_arr%values(62)%obj = transfer_values_to_mp(water%SNLIQ ) !SNLIQ array (-levels%NSNOW+1:0) + mp_arr%values(63)%obj = transfer_values_to_mp(water%ETRANI ) !ETRANI array (1:levels%NSOIL) + mp_arr%values(64)%obj = transfer_values_to_mp(water%FCR ) !FCR array (1:levels%nsoil) + +END SUBROUTINE water_serialization + +SUBROUTINE water_deserialization (mp_arr, water) + class(mp_arr_type), allocatable, intent(in) :: mp_arr + type(water_type), intent(inout) :: water + real(kind=real64) :: deserialized_val + integer(kind=int64) :: deserialized_int_val + class(mp_arr_type), allocatable :: mp_sub_arr + logical :: status + integer(kind=int64) :: index, sub_index + + do index=1, mp_arr%numelements() + if (index .LE. 52) then + call get_real(mp_arr%values(index)%obj, deserialized_val, status) + else if (index == 53) then + call get_int(mp_arr%values(index)%obj, deserialized_int_val, status) + else if (index .GE. 54) then + if (is_arr(mp_arr%values(index)%obj)) then + call get_arr_ref(mp_arr%values(index)%obj, mp_sub_arr, status) + end if + end if + select case(index) + case(1) + water%FP = deserialized_val + case(2) + water%RAIN = deserialized_val + case(3) + water%SNOW = deserialized_val + case(4) + water%BDFALL = deserialized_val + case(5) + water%QINTR = deserialized_val + case(6) + water%QDRIPR = deserialized_val + case(7) + water%QTHROR = deserialized_val + case(8) + water%QINTS = deserialized_val + case(9) + water%QDRIPS = deserialized_val + case(10) + water%QTHROS = deserialized_val + case(11) + water%QRAIN = deserialized_val + case(12) + water%QSNOW = deserialized_val + case(13) + water%SNOWHIN = deserialized_val + case(14) + water%CANLIQ = deserialized_val + case(15) + water%CANICE = deserialized_val + case(16) + water%FWET = deserialized_val + case(17) + water%CMC = deserialized_val + case(18) + water%FSNO = deserialized_val + case(19) + water%BDSNO = deserialized_val + case(20) + water%BTRAN = deserialized_val + case(21) + water%SNEQV = deserialized_val + case(22) + water%SNOWH = deserialized_val + case(23) + water%PONDING = deserialized_val + case(24) + water%SNEQVO = deserialized_val + case(25) + water%QVAP = deserialized_val + case(26) + water%QDEW = deserialized_val + case(27) + water%QSNSUB = deserialized_val + case(28) + water%QSEVA = deserialized_val + case(29) + water%QSNFRO = deserialized_val + case(30) + water%QSDEW = deserialized_val + case(31) + water%QINSUR = deserialized_val + case(32) + water%ACSNOM = deserialized_val + case(33) + water%RUNSRF = deserialized_val + case(34) + water%WSLAKE = deserialized_val + case(35) + water%EVAPOTRANS = deserialized_val + case(36) + water%ECAN = deserialized_val + case(37) + water%ETRAN = deserialized_val + case(38) + water%SNOFLOW = deserialized_val + case(39) + water%PONDING1 = deserialized_val + case(40) + water%PONDING2 = deserialized_val + case(41) + water%QSNBOT = deserialized_val + case(42) + water%RUNSUB = deserialized_val + case(43) + water%PDDUM = deserialized_val + case(44) + water%runsrf_dt = deserialized_val + case(45) + water%SICEMAX = deserialized_val + case(46) + water%FCRMAX = deserialized_val + case(47) + water%FACC = deserialized_val + case(48) + water%QDRAIN = deserialized_val + case(49) + water%DEEPRECH = deserialized_val + case(50) + water%ZWT = deserialized_val + case(51) + water%ASAT = deserialized_val + case(52) + water%SMCWTD = deserialized_val + case(53) + water%ISNOW = deserialized_int_val + case(54) + water%BTRANI = transfer_values_from_mp(mp_sub_arr) + case(55) + water%SNICEV = transfer_values_from_mp(mp_sub_arr) + case(56) + water%EPORE = transfer_values_from_mp(mp_sub_arr) + case(57) + water%SNLIQV = transfer_values_from_mp(mp_sub_arr) + case(58) + water%SICE = transfer_values_from_mp(mp_sub_arr) + case(59) + water%SH2O = transfer_values_from_mp(mp_sub_arr) + case(60) + water%SMC = transfer_values_from_mp(mp_sub_arr) + case(61) + water%SNICE = transfer_values_from_mp(mp_sub_arr) + case(62) + water%SNLIQ = transfer_values_from_mp(mp_sub_arr) + case(63) + water%ETRANI = transfer_values_from_mp(mp_sub_arr) + case(64) + water%FCR = transfer_values_from_mp(mp_sub_arr) + end select + end do +END SUBROUTINE water_deserialization + +SUBROUTINE parameters_serialization (parameters, mp_arr) + type(parameters_type), intent(in) :: parameters + class(mp_arr_type), allocatable, intent(out) :: mp_arr + + mp_arr = mp_arr_type(5) + mp_arr%values(1)%obj = mp_float_type(parameters%SAI) !SAI + mp_arr%values(2)%obj = mp_float_type(parameters%LAI) !LAI + mp_arr%values(3)%obj = mp_float_type(parameters%ESAI) !ESAI + mp_arr%values(4)%obj = mp_float_type(parameters%ELAI) !ELAI + mp_arr%values(4)%obj = mp_float_type(parameters%FVEG) !FVEG + +END SUBROUTINE parameters_serialization + +SUBROUTINE parameters_deserialization (mp_arr, parameters) + class(mp_arr_type), allocatable, intent(in) :: mp_arr + type(parameters_type), intent(inout) :: parameters + real(kind=real64) :: deserialized_val + logical :: status + integer(kind=int64) :: index + + do index=1, mp_arr%numelements() + call get_real(mp_arr%values(index)%obj, deserialized_val, status) + select case(index) + case(1) + parameters%SAI = deserialized_val + case(2) + parameters%LAI = deserialized_val + case(3) + parameters%ESAI = deserialized_val + case(4) + parameters%ELAI = deserialized_val + case(5) + parameters%FVEG = deserialized_val + end select + end do +END SUBROUTINE parameters_deserialization + +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_to_mp_int (src) RESULT (dest) + +integer, 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_int_type(src(index)) + end do + +END FUNCTION transfer_values_to_mp_int + +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 + +FUNCTION transfer_values_from_mp_int (src) RESULT (dest) + +class(mp_arr_type), allocatable, intent(in) :: src +integer, allocatable, dimension(:) :: dest +integer(kind=int64) :: deserialized_int_val +integer(kind=int64) :: index +logical :: status + + do index=1, src%numelements() + call get_int(src%values(index)%obj, deserialized_int_val, status) + dest(index) = deserialized_int_val + end do + +END FUNCTION transfer_values_from_mp_int + +END Module diff --git a/src/byte_utilities.f90 b/src/byte_utilities.f90 new file mode 100644 index 0000000..fb3e2e9 --- /dev/null +++ b/src/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/messagepack.f90 b/src/messagepack.f90 new file mode 100644 index 0000000..1d4c2a5 --- /dev/null +++ b/src/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/messagepack_user.f90 b/src/messagepack_user.f90 new file mode 100644 index 0000000..fa2394a --- /dev/null +++ b/src/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/messagepack_value.f90 b/src/messagepack_value.f90 new file mode 100644 index 0000000..e3044e1 --- /dev/null +++ b/src/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