Serialization and get/set value functions for NOAH-OWP-MODULAR

bmi/bmi_noahowp.f90

@@ -620,6 +620,9 @@ 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_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 +637,15 @@ 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_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 +887,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") 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)
+         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 +950,14 @@ function noahowp_get_int(this, name, dest) result (bmi_status)
     case("ISNOW")
        dest(:) = this%model%water%ISNOW
        bmi_status = BMI_SUCCESS
+    case("serialization_state")
+        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)
+            bmi_status = BMI_SUCCESS
+         end if
     case default
        dest(:) = -1
        bmi_status = BMI_FAILURE
@@ -1237,14 +1274,30 @@ 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 =================
 
     select case(name)
 !     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
+         else
+            bmi_status = BMI_FAILURE 
+         end if
+      case("serialization_state")
+         call deserialize_mp_buffer(this%model)
+         bmi_status = BMI_SUCCESS
+      case("serialization_free")
+         if(allocated(this%model%serialization_buffer)) then
+            deallocate(this%model%serialization_buffer)
+            bmi_status = BMI_SUCCESS
+         end if
+      case default
        bmi_status = BMI_FAILURE
        call write_log("bmi:noahowp_set_int: invalid var " // name, LOG_LEVEL_WARNING)
     end select

src/RunModule.f90

@@ -18,6 +18,9 @@ module RunModule
   use EnergyModule
   use WaterModule
   use DateTimeUtilsModule
+  use noahowp_log_module
+  use messagepack
+  use iso_fortran_env
 
   implicit none
   type :: noahowp_type
@@ -29,6 +32,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 +241,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 +336,46 @@ SUBROUTINE solve_noahowp(model)
     end associate ! terminate associate block
   END SUBROUTINE solve_noahowp
 
+  SUBROUTINE new_serialization_request (model, exec_status)
+    type(sac_type), intent(inout) :: model
+
+    integer(kind=int64) :: nh !counter for HRUs
+    class(msgpack), allocatable :: mp
+    class(mp_arr_type), allocatable :: mp_sub_arr
+    class(mp_arr_type), allocatable :: mp_arr
+    byte, dimension(:), allocatable :: serialization_buffer
+    integerkind=int64, intent(out) :: exec_status
+
+    mp = msgpack()
+    mp_arr = mp_arr_type(model%runinfo%n_hrus)
+    do nh=1, model%runinfo%n_hrus
+        mp_sub_arr = mp_arr_type(11)
+        mp_sub_arr%values(1)%obj = mp_int_type(model%runinfo%curr_yr) !curr_yr
+        mp_sub_arr%values(2)%obj = mp_int_type(model%runinfo%curr_mo) !curr_mo
+        mp_sub_arr%values(3)%obj = mp_int_type(model%runinfo%curr_dy) !curr_dy
+        mp_sub_arr%values(4)%obj = mp_int_type(model%runinfo%curr_hr) !curr_hr
+        mp_sub_arr%values(5)%obj = mp_int_type(nh) !hru number
+        mp_sub_arr%values(6)%obj = mp_float_type(model%modelvar%uztwc(nh)) !uztwc
+        mp_sub_arr%values(7)%obj = mp_float_type(model%modelvar%uzfwc(nh)) !uzfwc
+        mp_sub_arr%values(8)%obj = mp_float_type(model%modelvar%lztwc(nh)) !lztwc
+        mp_sub_arr%values(9)%obj = mp_float_type(model%modelvar%lzfsc(nh)) !lzfsc
+        mp_sub_arr%values(10)%obj = mp_float_type(model%modelvar%lzfpc(nh)) !lzfpc
+        mp_sub_arr%values(11)%obj = mp_float_type(model%modelvar%adimc(nh)) !adimc
+
+        mp_arr%values(nh)%obj = mp_sub_arr
+    end do
+
+    ! 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
+
+
 end module RunModule

src/StateSerialization.f90

@@ -0,0 +1,78 @@
+module StateSerialization
+
+  use LevelsType
+  use DomainType
+  use ParametersType
+  use WaterType
+  use EnergyType
+  use ForcingType
+  use SnowWaterRenew
+  use SnowLayerChange
+  use messagepack
+  use iso_fortran_env
+
+  implicit none
+  byte, dimension(:), allocatable :: serialization_buffer
+
+contains
+
+SUBROUTINE forcing_serialization (forcing)
+    type(ForcingType), 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_int_type(forcing%YEARLEN) !YEARLEN, out
+    mp_arr%values(9)%obj = mp_float_type(forcing%JULIAN) !JULIAN, out
+    mp_arr%values(10)%obj = mp_float_type(forcing%THAIR) !THAIR, out
+    mp_arr%values(11)%obj = mp_float_type(mforcing%QAIR) !QAIR, out
+    mp_arr%values(12)%obj = mp_float_type(forcing%EAIR) !EAIR, out
+    mp_arr%values(13)%obj = mp_float_type(forcing%RHOAIR) !RHOAIR, out
+    mp_arr%values(14)%obj = mp_float_type(forcing%O2PP) !O2PP
+    mp_arr%values(15)%obj = mp_float_type(forcing%CO2PP) !CO2PP
+    mp_arr%values(16)%obj = mp_float_type(forcing%SWDOWN) !SWDOWN, out
+    mp_arr%values(17)%obj = mp_float_type(forcing%SOLAD) !SOLAD
+    mp_arr%values(18)%obj = mp_float_type(forcing%SOLAI) !SOLAI
+    mp_arr%values(19)%obj = mp_float_type(forcing%PRCP) !PRCP
+    mp_arr%values(20)%obj = mp_float_type(forcing%PRCPNONC) !PRCPNONC
+    mp_arr%values(21)%obj = mp_float_type(mforcing%FPICE) !FPICE, out 
+    mp_arr%values(22)%obj = mp_float_type(forcing%UR) !UR, out
+
+END SUBROUTINE forcing_serialization
+
+SUBROUTINE domain_serialization (domain)
+    type(ForcingType), 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%ITIME) !ITIME
+    mp_arr%values(3)%obj = mp_float_type(domain%time_dbl) !time_dbl
+    mp_arr%values(4)%obj = mp_float_type(domain%nowdate) !nowdate
+
+    mp_arr%values(5)%obj = mp_arr_type(domain%DZSNSO) !DZSNSO have to fix indices using levels%soil
+    mp_arr%values(6)%obj = mp_arr_type(domain%ZSNSO) !ZSNSO have to fix indices using levels%soil
+
+END SUBROUTINE domain_serialization (domain)
+
+SUBROUTINE domain_serialization (domain)
+    type(ForcingType), 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%ITIME) !ITIME
+    mp_arr%values(3)%obj = mp_float_type(domain%time_dbl) !time_dbl
+    mp_arr%values(4)%obj = mp_float_type(domain%nowdate) !nowdate
+
+    mp_arr%values(5)%obj = mp_arr_type(domain%DZSNSO) !DZSNSO have to fix indices using levels%soil
+    mp_arr%values(6)%obj = mp_arr_type(domain%ZSNSO) !ZSNSO have to fix indices using levels%soil
+
+END SUBROUTINE domain_serialization (domain)
+
+END Module

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