diff --git a/INSTALL.md b/INSTALL.md index 3d47e453..be6ccb93 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. @@ -41,6 +42,33 @@ The `namelist.input` file in `/run` includes all the setup and options info you You can examine model output in the `/data/output.nc` file (requires [Panoply](https://www.giss.nasa.gov/tools/panoply/) or other NetCDF viewer). +## Logger + +The Errror Warning and Trapping Systems (EWTS) has been added to this module using a logging schema. All write statements have been converted to `write_log` statements, which saves the ouptut to a log file based on the log level. + +When running within the ngen framework, the log file and log level are handled programatically. When running standalone, logging is defaulted to DISABLED. + +**Running Standalone** + +In order to generate log messages when running standalone, the `NGEN_EWTS_LOGGING` environment variable must be set to `ENABLED`. This is the only required environment variable . Other optional logger environment variables exist for specifying the log file full pathname and setting the log level. If the user only enables logging, the log level will be set to INFO and the filename will be created based on the user and module names. All logger setup details are written to the console when the module is run. +``` +# Case Sensitive +export NGEN_EWTS_LOGGING=ENABLED +export NGEN_LOG_FILE_PATH= +export NOAHOWP_LOGLEVEL= +``` +**Log Levels** +| Level | Description | Typical Use | +|---------|-----------------------------------------------------|-----------------------------------------------| +| DEBUG | Detailed diagnostic info for development/troubleshooting. | Variable values, function entry/exit. | +| FATAL | Critical failure that aborts or makes app unrecoverable. | Crashes, memory errors, invalid state. | +| INFO | General events confirming expected operations. | Startup/shutdown, configs, task completions. | +| SEVERE | Significant problem; app may continue in degraded state. | Failed services, corrupted configs, data loss.| +| WARNING | Potential issue that doesn’t stop execution. | Deprecated APIs, missing files, repeatable errors. | + +Default log level is INFO. The log level is hierarchical. Setting it to INFO, will log INFO, WARNING, SEVERE and FATAL +messages. + ## BMI unit tests To run unit tests, first compile and link the test program from the main-level directory: diff --git a/LICENSE b/LICENSE index d6456956..01fbb8df 100644 --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,25 @@ +Copyright 2025 Raytheon Company + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +Licensed under: https://opensource.org/license/bsd-2-clause + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +All rights reserved. Based on Government sponsored work under contract GS-35F-204GA. + +----------------- + +“Software code created by U.S. Government employees is not subject to copyright +in the United States (17 U.S.C. §105). The United States/Department of Commerce +reserve all rights to seek and obtain copyright protection in countries other +than the United States for Software authored in its entirety by the Department +of Commerce. To this end, the Department of Commerce hereby grants to Recipient +a royalty-free, nonexclusive license to use, copy, and create derivative works +of the Software outside of the United States.” Apache License Version 2.0, January 2004 diff --git a/Makefile b/Makefile index 7a04031a..cf7d639c 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,7 @@ .SUFFIXES: .o .f90 all: user_build_options + (cd fdatetime; make) (cd src; make) (cd bmi; make) (cd driver; make) diff --git a/bmi/bmi_noahowp.f90 b/bmi/bmi_noahowp.f90 index 1a8b8b0f..d3cb79c2 100644 --- a/bmi/bmi_noahowp.f90 +++ b/bmi/bmi_noahowp.f90 @@ -1,5 +1,5 @@ module bminoahowp - + use noahowp_log_module ! NGEN_ACTIVE is to be set when running in the Nextgen framework ! https://github.com/NOAA-OWP/ngen #ifdef NGEN_ACTIVE @@ -195,6 +195,8 @@ function noahowp_initialize(this, config_file) result (bmi_status) character (len=*), intent(in) :: config_file integer :: bmi_status + !call create_logger() + call write_log("Initializing NOAHOWP BMI", LOG_LEVEL_INFO) if (len(config_file) > 0) then call initialize_from_file(this%model, config_file) else @@ -278,9 +280,12 @@ function noahowp_update_until(this, time) result (bmi_status) integer :: bmi_status double precision :: n_steps_real integer :: n_steps, i, s + character(50) :: str_real if (time < this%model%domain%time_dbl) then bmi_status = BMI_FAILURE + write(str_real, '(f20.10)' ) time + call write_log("bmi:noahowp_update_until: time " // trim(str_real) //" is less than time_dbl", LOG_LEVEL_FATAL) return end if @@ -318,6 +323,7 @@ function noahowp_var_grid(this, name, grid) result (bmi_status) bmi_status = BMI_SUCCESS case default grid = -1 + call write_log("bmi:noahowp_var_grid: invalid variable " // name // ". Grid set to -1", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_var_grid @@ -342,6 +348,7 @@ function noahowp_grid_type(this, grid, type) result (bmi_status) ! bmi_status = BMI_SUCCESS case default type = "-" + call write_log("bmi:noahowp_grid_type: invalid grid " // itoa(grid) // ". Type set to -", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_type @@ -366,6 +373,7 @@ function noahowp_grid_rank(this, grid, rank) result (bmi_status) ! bmi_status = BMI_SUCCESS case default rank = -1 + call write_log("bmi:noahowp_grid_rank: invalid grid " // itoa(grid) // ". Rank set to -1", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_rank @@ -391,6 +399,7 @@ function noahowp_grid_shape(this, grid, shape) result (bmi_status) bmi_status = BMI_SUCCESS case default shape(:) = -1 + call write_log("bmi:noahowp_grid_shape: invalid grid " // itoa(grid) // ". shape set to -1", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_shape @@ -418,6 +427,7 @@ function noahowp_grid_size(this, grid, size) result (bmi_status) bmi_status = BMI_SUCCESS case default size = -1 + call write_log("bmi:noahowp_grid_shape: invalid grid " // itoa(grid) // ". Size set to -1", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_size @@ -437,6 +447,7 @@ function noahowp_grid_spacing(this, grid, spacing) result (bmi_status) ! bmi_status = BMI_SUCCESS case default spacing(:) = -1.d0 + call write_log("bmi:noahowp_grid_spacing: invalid grid " // itoa(grid) // ". Spacing set to -1.d0", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_spacing @@ -456,6 +467,7 @@ function noahowp_grid_origin(this, grid, origin) result (bmi_status) ! bmi_status = BMI_SUCCESS case default origin(:) = -1.d0 + call write_log("bmi:noahowp_grid_origin: invalid grid " // itoa(grid) // ". Origin set to -1.d0", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_origin @@ -473,6 +485,7 @@ function noahowp_grid_x(this, grid, x) result (bmi_status) bmi_status = BMI_SUCCESS case default x(:) = -1.d0 + call write_log("bmi:noahowp_grid_x: invalid grid " // itoa(grid) // ". x value set to -1.d0", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_x @@ -490,6 +503,7 @@ function noahowp_grid_y(this, grid, y) result (bmi_status) bmi_status = BMI_SUCCESS case default y(:) = -1.d0 + call write_log("bmi:noahowp_grid_y: invalid grid " // itoa(grid) // ". y value set to -1.d0", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select end function noahowp_grid_y @@ -508,6 +522,7 @@ function noahowp_grid_z(this, grid, z) result (bmi_status) case default z(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_z: invalid grid " // itoa(grid) // ". z value set to -1.d0", LOG_LEVEL_WARNING) end select end function noahowp_grid_z @@ -524,6 +539,7 @@ function noahowp_grid_node_count(this, grid, count) result(bmi_status) case default count = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_node_count: invalid grid " // itoa(grid) // ". Count value set to -1", LOG_LEVEL_WARNING) end select end function noahowp_grid_node_count @@ -536,6 +552,7 @@ function noahowp_grid_edge_count(this, grid, count) result(bmi_status) count = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_edge_count: invalid grid " // itoa(grid) // ". Count value set to -1", LOG_LEVEL_WARNING) end function noahowp_grid_edge_count ! Get the number of faces in an unstructured grid. @@ -547,6 +564,7 @@ function noahowp_grid_face_count(this, grid, count) result(bmi_status) count = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_face_count: invalid grid " // itoa(grid) // ". Count value set to -1", LOG_LEVEL_WARNING) end function noahowp_grid_face_count ! Get the edge-node connectivity. @@ -558,6 +576,7 @@ function noahowp_grid_edge_nodes(this, grid, edge_nodes) result(bmi_status) edge_nodes(:) = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_edge_nodes: invalid grid " // itoa(grid) // ". Edge nodes value set to -1", LOG_LEVEL_WARNING) end function noahowp_grid_edge_nodes ! Get the face-edge connectivity. @@ -569,6 +588,7 @@ function noahowp_grid_face_edges(this, grid, face_edges) result(bmi_status) face_edges(:) = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_face_edges: invalid grid " // itoa(grid) // ". Face edge value set to -1", LOG_LEVEL_WARNING) end function noahowp_grid_face_edges ! Get the face-node connectivity. @@ -591,6 +611,7 @@ function noahowp_grid_nodes_per_face(this, grid, nodes_per_face) result(bmi_stat nodes_per_face(:) = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_grid_nodes_per_face: invalid grid " // itoa(grid) // ". nodes_per_face value set to -1", LOG_LEVEL_WARNING) end function noahowp_grid_nodes_per_face ! The data type of the variable, as a string. @@ -599,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', & @@ -613,9 +638,22 @@ 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 + call write_log("bmi:noahowp_var_type: invalid var " // name // ". type value set to '-'", LOG_LEVEL_WARNING) end select end function noahowp_var_type @@ -671,6 +709,7 @@ function noahowp_var_units(this, name, units) result (bmi_status) bmi_status = BMI_SUCCESS case default units = "-" + call write_log("bmi:noahowp_var_units: invalid var " // name // ". unit value set to '-'", LOG_LEVEL_WARNING) bmi_status = BMI_FAILURE end select @@ -839,6 +878,7 @@ function noahowp_var_itemsize(this, name, size) result (bmi_status) case default size = -1 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_var_itemsize: invalid var " // name // ". size value set to -1", LOG_LEVEL_WARNING) end select end associate end function noahowp_var_itemsize @@ -851,19 +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 + 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 @@ -896,9 +954,18 @@ 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 + call write_log("bmi:noahowp_get_int: invalid var " // name // ". dest value set to '-1'", LOG_LEVEL_WARNING) end select end function noahowp_get_int @@ -1065,6 +1132,7 @@ function noahowp_get_float(this, name, dest) result (bmi_status) case default dest(:) = -1.0 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_float: invalid var " // name // ". dest value set to '-1.0'", LOG_LEVEL_WARNING) end select end associate ! NOTE, if vars are gridded, then use: @@ -1084,6 +1152,7 @@ function noahowp_get_double(this, name, dest) result (bmi_status) case default dest(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_double: invalid var " // name // ". return value set to '-1.d0'", LOG_LEVEL_WARNING) end select end function noahowp_get_double @@ -1097,8 +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 + 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 @@ -1114,6 +1187,7 @@ function noahowp_get_ptr_float(this, name, dest_ptr) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_ptr_float: invalid var " // name, LOG_LEVEL_WARNING) end select call c_f_pointer(src, dest_ptr, [n_elements]) @@ -1132,6 +1206,7 @@ function noahowp_get_ptr_double(this, name, dest_ptr) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_ptr_double: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_get_ptr_double @@ -1150,6 +1225,7 @@ function noahowp_get_at_indices_int(this, name, dest, inds) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_at_indices_int: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_get_at_indices_int @@ -1176,6 +1252,7 @@ function noahowp_get_at_indices_float(this, name, dest, inds) & ! bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_at_indices_float: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_get_at_indices_float @@ -1194,6 +1271,7 @@ function noahowp_get_at_indices_double(this, name, dest, inds) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_get_at_indices_double: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_get_at_indices_double @@ -1203,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 ================= @@ -1210,8 +1289,26 @@ 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 end function noahowp_set_int @@ -1335,6 +1432,7 @@ function noahowp_set_float(this, name, src) result (bmi_status) bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_set_float: invalid var " // name, LOG_LEVEL_WARNING) end select end associate ! NOTE, if vars are gridded, then use: @@ -1353,6 +1451,7 @@ function noahowp_set_double(this, name, src) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_set_double: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_set_double @@ -1371,6 +1470,7 @@ function noahowp_set_at_indices_int(this, name, inds, src) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_set_at_indices_int: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_set_at_indices_int @@ -1396,6 +1496,7 @@ function noahowp_set_at_indices_float(this, name, inds, src) & ! bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_set_at_indices_float: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_set_at_indices_float @@ -1414,6 +1515,7 @@ function noahowp_set_at_indices_double(this, name, inds, src) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("bmi:noahowp_set_at_indices_double: invalid var " // name, LOG_LEVEL_WARNING) end select end function noahowp_set_at_indices_double @@ -1459,6 +1561,7 @@ function register_bmi(this) result(bmi_status) bind(C, name="register_bmi") if( .not. associated( bmi_box ) .or. .not. associated( bmi_box%ptr ) ) then bmi_status = BMI_FAILURE + call write_log("bmi:register_bmi: bmi_box error", LOG_LEVEL_WARNING) else !Return the pointer to box this = c_loc(bmi_box) diff --git a/config/user_build_options.gfortran.ubuntu b/config/user_build_options.gfortran.ubuntu new file mode 100644 index 00000000..ac623c0f --- /dev/null +++ b/config/user_build_options.gfortran.ubuntu @@ -0,0 +1,15 @@ + +#============================================================================================= +# Options for Linux with gfortran, NETCDF via source +#============================================================================================= + + COMPILERF90 = gfortran + FREESOURCE = -ffree-form -ffree-line-length-none + F90FLAGS = -g -fbacktrace -Wall -fcheck=all #-fdefault-real-8 + CPP = cpp + CPPFLAGS = -P -traditional -D_GFORTRAN_ + NETCDFINC = /usr + NETCDF = /usr/lib/x86_64-linux-gnu + NETCDFMOD = -I${NETCDFINC}/include + NETCDFLIB = -L${NETCDF} -lnetcdf -lnetcdff + diff --git a/configure b/configure index 82dd52d9..c022f797 100755 --- a/configure +++ b/configure @@ -11,6 +11,7 @@ print " 3. MacOS gfortran compiler, NETCDF from source \n"; print " 4. MacOS BigSur gfortran compiler, NETCDF from Brew \n"; print " 5. Linux gfortran compiler, NETCDF from source or module load \n"; + print " 6. Ubuntu gfortran compiler, NETCDF from package \n"; print " 0. exit only \n"; printf "\nEnter selection : " ; @@ -42,6 +43,10 @@ # Linux, gfortran, NETCDF from source system "cp config/user_build_options.gfortran.linux user_build_options"; } + elsif ($response == 6) { + # Ubuntu, gfortran, NETCDF from package + system "cp config/user_build_options.gfortran.ubuntu user_build_options"; + } else {print "no selection $response\n"; last} diff --git a/driver/AsciiReadModule.f90 b/driver/AsciiReadModule.f90 index 57df6d6a..d758901a 100644 --- a/driver/AsciiReadModule.f90 +++ b/driver/AsciiReadModule.f90 @@ -1,5 +1,6 @@ module AsciiReadModule - + + use noahowp_log_module use UtilitiesModule implicit none @@ -25,6 +26,7 @@ subroutine open_forcing_file(filename) write(*,'(/," ***** Problem *****")') write(*,'(" ***** File ''", A, "'' does not exist.")') trim(filename) write(*,'(" ***** Check the forcing file specified as a command-line argument",/)') + call write_log("Problem : File " // trim(filename) // " does not exist. STOPPING ..", LOG_LEVEL_FATAL) stop ": ERROR EXIT" endif @@ -32,6 +34,7 @@ subroutine open_forcing_file(filename) open(10, file = trim(filename), form = 'formatted', action = 'read', iostat = ierr) if (ierr /= 0) then write(*,'("Problem opening file ''", A, "''")') trim(filename) + call write_log("Problem opening file "// trim(filename) //". STOPPING ..", LOG_LEVEL_FATAL) stop ": ERROR EXIT" endif @@ -168,6 +171,7 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & endif if (ierr /= 0) then write(*,'("Error reading from data file.")') + call write_log("read_forcing_text: Error reading from data file.", LOG_LEVEL_WARNING) ierr = 2 return endif @@ -185,6 +189,7 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & before = fdata ( readdate, read_windspeed, read_winddir, read_temperature, read_humidity, read_pressure, read_swrad, read_lwrad, read_rain ) cycle READLOOP else + call write_log("read_forcing_text: Logic problem. STOPPING..", LOG_LEVEL_FATAL) stop "Logic problem" endif enddo READLOOP @@ -226,6 +231,8 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & print*, 'idts = ', idts print*,' after%readdate = ', after%readdate print*, 'idts2 = ', idts2 + + call write_log("IDTS PROBLEM: idts2 = "//itoa(idts2)//" forcing_timestep = " //itoa(forcing_timestep) //" STOPPING..", LOG_LEVEL_FATAL) stop "IDTS PROBLEM" endif @@ -251,6 +258,7 @@ subroutine read_forcing_text(iunit, nowdate, forcing_timestep, & else print*, 'nowdate = "'//nowdate//'"' + call write_log('nowdate = "'//nowdate//'". Problem in the logic of read_forcing_text. STOPPING..', LOG_LEVEL_FATAL) stop "Problem in the logic of read_forcing_text." endif diff --git a/driver/NoahModularDriver.f90 b/driver/NoahModularDriver.f90 index a86ef930..d566ad96 100644 --- a/driver/NoahModularDriver.f90 +++ b/driver/NoahModularDriver.f90 @@ -6,6 +6,7 @@ program model_driver !--------------------------------------------------------------------- use bminoahowp use bmif_2_0 + use noahowp_log_module implicit none @@ -27,6 +28,7 @@ program model_driver ! All driver initialization code in ../src/RunModule.f90 !--------------------------------------------------------------------- print*, "Initializing..." + call write_log("Initializing NoahModularDriver", LOG_LEVEL_INFO) call get_command_argument(1, arg) status = m%initialize(arg) @@ -41,6 +43,7 @@ program model_driver ! loop through while current time <= end time print*, "Running..." + call write_log("Running NoahModularDriver", LOG_LEVEL_INFO) do while (current_time < end_time) status = m%update() ! run the model one time step status = m%get_current_time(current_time) ! update current_time @@ -51,7 +54,9 @@ program model_driver ! All model finalization code in ../src/RunModule.f90 !--------------------------------------------------------------------- print*, "Finalizing..." + call write_log("Finalizing NoahModularDriver", LOG_LEVEL_INFO) status = m%finalize() + call write_log("Finished NoahModularDriver", LOG_LEVEL_INFO) print*, "Finished!" end program diff --git a/driver/OutputModule.f90 b/driver/OutputModule.f90 index 125e02ec..227a9233 100644 --- a/driver/OutputModule.f90 +++ b/driver/OutputModule.f90 @@ -1,5 +1,5 @@ module OutputModule - + use noahowp_log_module !--------------------------------------------------------------------- ! Compiler directive NGEN_OUTPUT_ACTIVE to be defined if ! Nextgen is writing model output (https://github.com/NOAA-OWP/ngen) @@ -87,7 +87,12 @@ subroutine initialize_output(output_filename, ntime, nsoil, nsnow) ! time variable (need units / time datum) !iret = nf90_def_var(ncid, "timestep", NF90_INT , (/time_dim/), time_id) !iret = nf90_def_var(ncid, "time", NF90_DOUBLE, (/time_dim/), time_id) - call check (nf90_def_var(ncid, "time", NF90_DOUBLE, (/time_dim/), time_id), "time var def error", iret); if (iret /= 0) return ! with error checking + call check (nf90_def_var(ncid, "time", NF90_DOUBLE, (/time_dim/), time_id), "time var def error", iret) + if (iret /= 0) then + call write_log("time var def error. Returning", LOG_LEVEL_WARNING) + return ! with error checking + end if + iret = nf90_put_att(ncid, time_id, "units", time_units) !if (error /= 0) return @@ -232,12 +237,14 @@ subroutine check (status, info, error) integer, intent (out) :: error if (status /= nf90_noerr) then + call write_log(trim (info) // ": " // trim (nf90_strerror(status)), LOG_LEVEL_WARNING) print *, trim (info) // ": " // trim (nf90_strerror(status)) error = 1 end if end subroutine check - -#endif ! end of block to remove output if NGEN_OUTPUT_ACTIVE directive is True + +! end of block to remove output if NGEN_OUTPUT_ACTIVE directive is True +#endif end module OutputModule diff --git a/fdatetime/Makefile b/fdatetime/Makefile new file mode 100644 index 00000000..be0679ff --- /dev/null +++ b/fdatetime/Makefile @@ -0,0 +1,9 @@ +include ../user_build_options + +SRC = ../../../datetime-fortran-1.7.0/src/datetime_module.f90 +OBJ = datetime_module.o + +$(OBJ): $(SRC) + $(COMPILERF90) -c -o $@ $< $(F90FLAGS) +clean: + -rm -f $(OBJ) diff --git a/run/Makefile b/run/Makefile index ce0caeba..d76d95b0 100644 --- a/run/Makefile +++ b/run/Makefile @@ -6,6 +6,8 @@ include ../user_build_options OBJS = \ + ../fdatetime/datetime_module.o \ + ../src/noahowpLogger.o \ ../src/ErrorCheckModule.o \ ../src/NamelistRead.o \ ../src/ParametersRead.o \ @@ -39,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/CanopyWaterModule.f90 b/src/CanopyWaterModule.f90 index 176b2153..7a16038a 100644 --- a/src/CanopyWaterModule.f90 +++ b/src/CanopyWaterModule.f90 @@ -1,5 +1,4 @@ module CanopyWaterModule - use LevelsType use DomainType use OptionsType @@ -40,6 +39,7 @@ SUBROUTINE CanopyHydrology (domain, levels, options, parameters, forcing, energy REAL :: QFRZC !refreezing rate of canopy liquid water (mm/s) REAL :: CANMAS !total canopy mass (kg/m2) ! -------------------------------------------------------------------- + ! initialization water%ECAN = 0.0 diff --git a/src/DateTimeUtilsModule.f90 b/src/DateTimeUtilsModule.f90 index f394b6c8..90f45384 100644 --- a/src/DateTimeUtilsModule.f90 +++ b/src/DateTimeUtilsModule.f90 @@ -2,6 +2,7 @@ ! copied from the GMET code at https://github.com/NCAR/GMET/ module DateTimeUtilsModule + use noahowp_log_module implicit none public @@ -88,7 +89,7 @@ subroutine parse (str, delims, args, nargs) if (len_trim(str) == 0) exit nargs = nargs + 1 if(nargs .gt. size(args)) then - print *,'Number of predictors larger than expected, check nPredict' + call write_log("Number of predictors larger than expected, check nPredict", LOG_LEVEL_FATAL) stop end if call split (str, delims, args(nargs)) @@ -432,12 +433,12 @@ subroutine readline (nunitr, line, ios) do read (nunitr, '(a)', iostat=ios) line ! read input line - if (ios /= 0) return + if (ios /= 0) then; call write_log("Error reading line :"//line, LOG_LEVEL_WARNING); return; end if line = adjustl (line) ipos = index (line, '!') if (ipos == 1) cycle if (ipos /= 0) line = line (:ipos-1) - if (len_trim(line) /= 0) exit + if (len_trim(line) /= 0) then; call write_log("Empty Line : " //line//" Exiting", LOG_LEVEL_WARNING); exit; end if end do return @@ -881,11 +882,12 @@ double precision function date_to_unix (date) integer :: sec, min, hour, day, month, year, error call parse_date (date, year, month, day, hour, min, sec, error) - + !call write_log(date// "," //itoa(year)// "," //itoa(month)// "," //itoa(day)// "," //itoa(hour)// "," //itoa(min)// ","//itoa(sec)//"," //itoa(error), LOG_LEVEL_INFO) if (error /= 0) then date_to_unix = -9999.99 - print*, 'error in date_to_unix -- date, year, month, day, hour, min, sec, error:' - print*, date, year, month, day, hour, min, sec, error + call write_log('Error in date_to_unix -- date, year, month, day, hour, min, sec, error:', LOG_LEVEL_FATAL) + call write_log(date// "," //itoa(year)// "," //itoa(month)// "," //itoa(day)// "," //itoa(hour)// "," //itoa(min)// "," //itoa(sec)//"," //itoa(error), LOG_LEVEL_WARNING) + call write_log("STOPPING ..", LOG_LEVEL_FATAL) stop !return end if @@ -970,11 +972,20 @@ subroutine get_utime_list (start_datetime, end_datetime, dt, times) !local integer :: t, ntimes real*8 :: utime + character(50) :: str_mod + character(50) :: str_end + character(50) :: str_start + character(50) :: str_dt if(abs(mod(end_datetime - start_datetime, dt)) > 1e-5) then - print*, 'start and end datetimes are not an even multiple of dt -- check dates in namelist' - print*, 'end_datetime, start_datetime, dt, mod:', end_datetime, start_datetime, dt, mod(end_datetime-start_datetime, dt) - stop + write(str_mod, '(f20.10)' ) mod(end_datetime-start_datetime, dt) + write(str_end, '(f20.10)' ) end_datetime + write(str_start, '(f20.10)' ) start_datetime + write(str_dt, '(f20.10)' ) dt + + call write_log('start and end datetimes are not an even multiple of dt -- check dates in namelist', LOG_LEVEL_FATAL) + call write_log('end_datetime, start_datetime, dt, mod:'//trim(str_end)//trim(str_start)//trim(str_dt)//trim(str_mod), LOG_LEVEL_FATAL) + stop end if ntimes = int((end_datetime - start_datetime)/dt) + 1 diff --git a/src/EnergyModule.f90 b/src/EnergyModule.f90 index c68947b8..efb555c6 100644 --- a/src/EnergyModule.f90 +++ b/src/EnergyModule.f90 @@ -1,5 +1,6 @@ module EnergyModule + use noahowp_log_module use LevelsType use DomainType use OptionsType @@ -301,10 +302,16 @@ SUBROUTINE EnergyMain (domain, levels, options, parameters, forcing, energy, wat FIRE = forcing%LWDN + energy%FIRA IF(FIRE <=0.) THEN WRITE(*,*) 'emitted longwave <0; skin T may be wrong due to inconsistent' + call write_log('EnergyModule: emitted longwave <0; skin T may be wrong due to inconsistent', LOG_LEVEL_WARNING) WRITE(*,*) 'input of SHDFAC with LAI' + call write_log('input of SHDFAC with LAI', LOG_LEVEL_WARNING) WRITE(*,*) domain%ILOC, domain%JLOC, 'SHDFAC=',parameters%FVEG,'parameters%VAI=',parameters%VAI,'TV=',energy%TV,'TG=',energy%TG WRITE(*,*) 'LWDN=',forcing%LWDN,'energy%FIRA=',energy%FIRA,'water%SNOWH=',water%SNOWH WRITE(*,*) 'Exiting ...' + call write_log(itoa(domain%ILOC) //", " //itoa(domain%JLOC)// ', SHDFAC=' //rtoa(parameters%FVEG), LOG_LEVEL_WARNING) + call write_log('parameters%VAI=' //rtoa(parameters%VAI )//' TV='//rtoa(energy%TV) //' TG='//rtoa(energy%TG), LOG_LEVEL_WARNING) + call write_log('LWDN='//rtoa(forcing%LWDN) //', energy%FIRA=' //rtoa(energy%FIRA)// ', water%SNOWH=' //rtoa(water%SNOWH), LOG_LEVEL_WARNING) + call write_log("Exiting ...", LOG_LEVEL_FATAL) STOP END IF diff --git a/src/ErrorCheckModule.f90 b/src/ErrorCheckModule.f90 index f3306965..a6f7e3de 100644 --- a/src/ErrorCheckModule.f90 +++ b/src/ErrorCheckModule.f90 @@ -1,6 +1,6 @@ module ErrorCheckModule - ! General error checking routins + use noahowp_log_module implicit none @@ -26,6 +26,7 @@ subroutine sys_abort(err, message) if(err/=0)then write(*, '(A)') 'FATAL ERROR: '//trim(message) + call write_log("FATAL ERROR: "//trim(message)// " STOPPING..", LOG_LEVEL_FATAL) call flush(6) stop endif @@ -45,6 +46,7 @@ function is_within_bound_int(var, lower_bound, upper_bound) result(withinbound) withinbound = .true. if ( var < lower_bound .or. var > upper_bound ) then + call write_log(itoa(var) //" is not within upper and lower bound", LOG_LEVEL_WARNING) withinbound = .false. end if @@ -63,6 +65,7 @@ function is_within_bound_real(var, lower_bound, upper_bound) result(withinbound) withinbound = .true. if ( var < lower_bound .or. var > upper_bound ) then + call write_log(rtoa(var) //" is not within upper and lower bound", LOG_LEVEL_WARNING) withinbound = .false. end if diff --git a/src/EtFluxModule.f90 b/src/EtFluxModule.f90 index 47387221..b57a0e2c 100644 --- a/src/EtFluxModule.f90 +++ b/src/EtFluxModule.f90 @@ -17,6 +17,8 @@ module EtFluxModule use EnergyType use ForcingType use OptionsType + use noahowp_log_module + implicit none !REAL, PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & @@ -1090,6 +1092,7 @@ SUBROUTINE SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in IF(ZLVL <= ZPD) THEN write(*,*) 'WARNING: critical problem: ZLVL <= ZPD; model stops' + call write_log('WARNING: critical problem: ZLVL <= ZPD; model stops', LOG_LEVEL_SEVERE) ENDIF TMPCM = LOG((ZLVL-ZPD) / Z0M) @@ -1501,4 +1504,4 @@ function PSPHS (YY) return end function -end module EtFluxModule \ No newline at end of file +end module EtFluxModule diff --git a/src/Makefile b/src/Makefile index e4cca0ea..ff444ae4 100644 --- a/src/Makefile +++ b/src/Makefile @@ -7,7 +7,8 @@ include ../user_build_options F90FLAGS := -cpp ${F90FLAGS} -OBJS = ErrorCheckModule.o \ +OBJS = noahowpLogger.o \ + ErrorCheckModule.o \ NamelistRead.o \ ParametersRead.o \ LevelsType.o \ @@ -40,12 +41,17 @@ OBJS = ErrorCheckModule.o \ EnergyModule.o \ UtilitiesModule.o \ DateTimeUtilsModule.o \ + byte_utilities.o \ + messagepack_value.o \ + messagepack_user.o \ + messagepack.o \ + StateSerialization.o \ RunModule.o all: $(OBJS) .f90.o: - $(COMPILERF90) -c $(F90FLAGS) $(FREESOURCE) $(NETCDFMOD) -I../driver $(*).f90 + $(COMPILERF90) -c $(F90FLAGS) $(FREESOURCE) $(NETCDFMOD) -I../driver -I../fdatetime $(*).f90 # # This command cleans up object (etc) files: @@ -61,6 +67,7 @@ clean: NamelistRead.o: ErrorCheckModule.o LevelsType.o: NamelistRead.o DomainType.o: NamelistRead.o LevelsType.o DateTimeUtilsModule.o +DateTimeUtilsModule.o: noahowpLogger.o OptionsType.o: NamelistRead.o ParametersType.o: NamelistRead.o ParametersRead.o ForcingType.o: NamelistRead.o @@ -105,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/NamelistRead.f90 b/src/NamelistRead.f90 index d175c4e6..3f51d933 100644 --- a/src/NamelistRead.f90 +++ b/src/NamelistRead.f90 @@ -1,5 +1,6 @@ module NamelistRead +use noahowp_log_module use ErrorCheckModule, only: sys_abort use ErrorCheckModule, only: is_within_bound @@ -229,26 +230,34 @@ subroutine ReadNamelist(this, namelist_file) ierr = 0 if( trim(namelist_file) .ne. '' ) then open(30, file=namelist_file, form="formatted", status='old', iostat=ierr) - if(ierr /= 0) then; write(*,'(A)') 'ERROR: user specified namelist file not found: '//trim(namelist_file); stop; end if + if(ierr /= 0) then + write(*,'(A)') 'ERROR: user specified namelist file not found: '//trim(namelist_file) + call write_log('ERROR: user specified namelist file not found: '//trim(namelist_file)// '...STOPPING..', LOG_LEVEL_FATAL) + stop + end if !print*, 'Reading namelist: ', trim(namelist_file) else open(30, file='./namelist.input', form="formatted", status='old', iostat=ierr) - if(ierr /= 0) then; write(*,'(A)') 'ERROR: default namelist file not found: ./namelist.input'; stop; end if + if(ierr /= 0) then + write(*,'(A)') 'ERROR: default namelist file not found: ./namelist.input' + call write_log('ERROR: default namelist file not found: ./namelist.input, STOPPING', LOG_LEVEL_FATAL) + stop + end if !print*, 'No namelist filename supplied -- attempting to read namelist.input (default)' endif read(30, timing, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if read(30, parameters, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if read(30, location, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if read(30, forcing, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if read(30, model_options, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if read(30, structure, iostat=ierr) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if !--------------------------------------------------------------------- ! Check model option validity, part 2 @@ -263,7 +272,7 @@ subroutine ReadNamelist(this, namelist_file) if (.not. is_within_bound(radiative_transfer_option,1, 3)) then; call sys_abort(1,'model options: radiative_transfer_option should be 1-3'); end if if (.not. is_within_bound(sfc_drag_coeff_option, 1, 2)) then; call sys_abort(1,'model options: sfc_drag_coeff_option should be 1-3'); end if if (.not. is_within_bound(canopy_stom_resist_option, 1, 2)) then; call sys_abort(1,'model options: sfc_drag_coeff_option should be 1-2'); end if - if (.not. is_within_bound(snowsoil_temp_time_option, 1, 3)) then; call sys_abort(1,'model options: snowsoil_temp_time_option should be 1-3'); end if + if (.not. is_within_bound(snowsoil_temp_time_option, 1, 3)) then; call sys_abort(1,'model options: snowsoil_temp_time_option should be 1-3'); end if if (.not. is_within_bound(soil_temp_boundary_option, 1, 2)) then; call sys_abort(1,'model options: soil_temp_boundary_option should be 1-2'); end if if (.not. is_within_bound(supercooled_water_option, 1, 2)) then; call sys_abort(1,'model options: supercooled_water_option should be 1-2'); end if if (.not. is_within_bound(stomatal_resistance_option, 1, 3)) then; call sys_abort(1,'model options: stomatal_resistance_option should be 1-3'); end if @@ -283,7 +292,7 @@ subroutine ReadNamelist(this, namelist_file) ! read remaining group from namelist read(30, initial_values) - if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; write(*,'(A)') 'ERROR: invalid line in namelist: '//trim(line); stop; end if + if (ierr/=0) then; backspace(30); read(30,fmt='(A)') line; call handle_err('ERROR: invalid line in namelist: '//trim(line)); end if close(30) ! calculate total soil depth and populate array for depth of layer-bottom from soil surface @@ -294,64 +303,63 @@ subroutine ReadNamelist(this, namelist_file) zsoil(iz) = -1. * sum(dzsnso(1:iz)) end do else + call write_log('ERROR: required entry dzsnso not found in namelist. STOPPING..', LOG_LEVEL_FATAL) write(*,'(A)') 'ERROR: required entry dzsnso not found in namelist'; stop end if !--------------------------------------------------------------------- ! transfer values to namelist data structure !--------------------------------------------------------------------- - if(dt /= realMissing) then; this%dt = dt; else; write(*,'(A)') 'ERROR: required entry dt not found in namelist'; stop; end if - if(startdate /= stringMissing) then; this%startdate = startdate; else; write(*,'(A)') 'ERROR: required entry startdate not found in namelist'; stop; end if - if(enddate /= stringMissing) then; this%enddate = enddate; else; write(*,'(A)') 'ERROR: required entry enddate not found in namelist'; stop; end if - if(forcing_filename /= stringMissing) then; this%forcing_filename = forcing_filename; else; write(*,'(A)') 'ERROR: required entry forcing_filename not found in namelist'; stop; end if - if(output_filename /= stringMissing) then; this%output_filename = output_filename; else; write(*,'(A)') 'ERROR: required entry output_filename not found in namelist'; stop; end if - if(parameter_dir /= stringMissing) then; this%parameter_dir = parameter_dir; else; write(*,'(A)') 'ERROR: required entry parameter_dir not found in namelist'; stop; end if - if(soil_table /= stringMissing) then; this%soil_table = soil_table; else; write(*,'(A)') 'ERROR: required entry soil_table not found in namelist'; stop; end if - if(general_table /= stringMissing) then; this%general_table = general_table; else; write(*,'(A)') 'ERROR: required entry general_table not found in namelist'; stop; end if - if(noahowp_table /= stringMissing) then; this%noahowp_table = noahowp_table; else; write(*,'(A)') 'ERROR: required entry noahowp_table not found in namelist'; stop; end if - if(soil_class_name /= stringMissing) then; this%soil_class_name = soil_class_name; else; write(*,'(A)') 'ERROR: required entry soil_class_name not found in namelist'; stop; end if - if(veg_class_name /= stringMissing) then; this%veg_class_name = veg_class_name; else; write(*,'(A)') 'ERROR: required entry veg_class_name not found in namelist'; stop; end if - - if(lat /= realMissing) then; this%lat = lat; else; write(*,'(A)') 'ERROR: required entry lat not found in namelist'; stop; end if - if(lon /= realMissing) then; this%lon = lon; else; write(*,'(A)') 'ERROR: required entry lon not found in namelist'; stop; end if - if(terrain_slope /= realMissing) then; this%terrain_slope = terrain_slope; else; write(*,'(A)') 'ERROR: required entry terrain_slope not found in namelist'; stop; end if - if(azimuth /= realMissing) then; this%azimuth = azimuth; else; write(*,'(A)') 'ERROR: required entry azimuth not found in namelist'; stop; end if - if(zref /= realMissing) then; this%ZREF = ZREF; else; write(*,'(A)') 'ERROR: required entry ZREF not found in namelist'; stop; end if - if(rain_snow_thresh /= realMissing) then; this%rain_snow_thresh = rain_snow_thresh; else; write(*,'(A)') 'ERROR: required entry rain_snow_thresh not found in namelist'; stop; end if - - if(isltyp /= integerMissing) then; this%isltyp = isltyp; else; write(*,'(A)') 'ERROR: required entry isltyp not found in namelist'; stop; end if - if(nsoil /= integerMissing) then; this%nsoil = nsoil; else; write(*,'(A)') 'ERROR: required entry nsoil not found in namelist'; stop; end if - if(nsnow /= integerMissing) then; this%nsnow = nsnow; else; write(*,'(A)') 'ERROR: required entry nsnow not found in namelist'; stop; end if - if(nveg /= integerMissing) then; this%nveg = nveg; else; write(*,'(A)') 'ERROR: required entry nveg not found in namelist'; stop; end if - if(soil_depth /= integerMissing) then; this%soil_depth = soil_depth; else; write(*,'(A)') 'ERROR: required entry soil_depth not found in namelist'; stop; end if - if(vegtyp /= integerMissing) then; this%vegtyp = vegtyp; else; write(*,'(A)') 'ERROR: required entry vegtyp not found in namelist'; stop; end if - if(croptype /= integerMissing) then; this%croptype = croptype; else; write(*,'(A)') 'ERROR: required entry croptype not found in namelist'; stop; end if - if(sfctyp /= integerMissing) then; this%sfctyp = sfctyp; else; write(*,'(A)') 'ERROR: required entry sfctyp not found in namelist'; stop; end if - if(soilcolor /= integerMissing) then; this%soilcolor = soilcolor; else; write(*,'(A)') 'ERROR: required entry soilcolor not found in namelist'; stop; end if + if(dt /= realMissing) then; this%dt = dt; else; call handle_err('ERROR: required entry dt not found in namelist'); end if + if(startdate /= stringMissing) then; this%startdate = startdate; else; call handle_err('ERROR: required entry startdate not found in namelist'); end if + if(enddate /= stringMissing) then; this%enddate = enddate; else; call handle_err('ERROR: required entry enddate not found in namelist'); end if + if(forcing_filename /= stringMissing) then; this%forcing_filename = forcing_filename; else; call handle_err('ERROR: required entry forcing_filename not found in namelist'); end if + if(output_filename /= stringMissing) then; this%output_filename = output_filename; else; call handle_err('ERROR: required entry output_filename not found in namelist'); end if + if(parameter_dir /= stringMissing) then; this%parameter_dir = parameter_dir; else; call handle_err('ERROR: required entry parameter_dir not found in namelist'); end if + if(soil_table /= stringMissing) then; this%soil_table = soil_table; else; call handle_err('ERROR: required entry soil_table not found in namelist'); end if + if(general_table /= stringMissing) then; this%general_table = general_table; else; call handle_err('ERROR: required entry general_table not found in namelist'); end if + if(noahowp_table /= stringMissing) then; this%noahowp_table = noahowp_table; else; call handle_err('ERROR: required entry noahowp_table not found in namelist'); end if + if(soil_class_name /= stringMissing) then; this%soil_class_name = soil_class_name; else; call handle_err('ERROR: required entry soil_class_name not found in namelist'); end if + if(veg_class_name /= stringMissing) then; this%veg_class_name = veg_class_name; else; call handle_err('ERROR: required entry veg_class_name not found in namelist'); end if + if(lat /= realMissing) then; this%lat = lat; else; call handle_err('ERROR: required entry lat not found in namelist'); end if + if(lon /= realMissing) then; this%lon = lon; else; call handle_err('ERROR: required entry lon not found in namelist'); end if + if(terrain_slope /= realMissing) then; this%terrain_slope = terrain_slope; else; call handle_err('ERROR: required entry terrain_slope not found in namelist'); end if + if(azimuth /= realMissing) then; this%azimuth = azimuth; else; call handle_err('ERROR: required entry azimuth not found in namelist'); end if + if(zref /= realMissing) then; this%ZREF = ZREF; else; call handle_err('ERROR: required entry ZREF not found in namelist'); end if + if(rain_snow_thresh /= realMissing) then; this%rain_snow_thresh = rain_snow_thresh; else; call handle_err('ERROR: required entry rain_snow_thresh not found in namelist'); end if - if(zsoil(1) /= realMissing) then; this%zsoil = zsoil; else; write(*,'(A)') 'ERROR: required entry zsoil not found in namelist'; stop; end if - if(dzsnso(1) /= realMissing) then; this%dzsnso = dzsnso; else; write(*,'(A)') 'ERROR: required entry dzsnso not found in namelist'; stop; end if - if(sice(1) /= realMissing) then; this%sice = sice; else; write(*,'(A)') 'ERROR: required entry sice not found in namelist'; stop; end if - if(sh2o(1) /= realMissing) then; this%sh2o = sh2o; else; write(*,'(A)') 'ERROR: required entry sh2o not found in namelist'; stop; end if - if(zwt /= realMissing) then; this%zwt = zwt; else; write(*,'(A)') 'ERROR: required entry zwt not found in namelist'; stop; end if + if(isltyp /= integerMissing) then; this%isltyp = isltyp; else; call handle_err('ERROR: required entry isltyp not found in namelist'); end if + if(nsoil /= integerMissing) then; this%nsoil = nsoil; else; call handle_err('ERROR: required entry nsoil not found in namelist'); end if + if(nsnow /= integerMissing) then; this%nsnow = nsnow; else; call handle_err('ERROR: required entry nsnow not found in namelist'); end if + if(nveg /= integerMissing) then; this%nveg = nveg; else; call handle_err('ERROR: required entry nveg not found in namelist'); end if + if(soil_depth /= integerMissing) then; this%soil_depth = soil_depth; else; call handle_err('ERROR: required entry soil_depth not found in namelist'); end if + if(vegtyp /= integerMissing) then; this%vegtyp = vegtyp; else; call handle_err('ERROR: required entry vegtyp not found in namelist'); end if + if(croptype /= integerMissing) then; this%croptype = croptype; else; call handle_err('ERROR: required entry croptype not found in namelist'); end if + if(sfctyp /= integerMissing) then; this%sfctyp = sfctyp; else; call handle_err('ERROR: required entry sfctyp not found in namelist'); end if + if(soilcolor /= integerMissing) then; this%soilcolor = soilcolor; else; call handle_err('ERROR: required entry soilcolor not found in namelist'); end if - if(precip_phase_option /= integerMissing) then; this%precip_phase_option = precip_phase_option; else; write(*,'(A)') 'ERROR: required entry precip_phase_option not found in namelist'; stop; end if - if(runoff_option /= integerMissing) then; this%runoff_option = runoff_option; else; write(*,'(A)') 'ERROR: required entry runoff_option not found in namelist'; stop; end if - if(drainage_option /= integerMissing) then; this%drainage_option = drainage_option; else; write(*,'(A)') 'ERROR: required entry drainage_option not found in namelist'; stop; end if - if(frozen_soil_option /= integerMissing) then; this%frozen_soil_option = frozen_soil_option; else; write(*,'(A)') 'ERROR: required entry frozen_soil_option not found in namelist'; stop; end if - if(dynamic_vic_option /= integerMissing) then; this%dynamic_vic_option = dynamic_vic_option; else; write(*,'(A)') 'ERROR: required entry dynamic_vic_option not found in namelist'; stop; end if - if(dynamic_veg_option /= integerMissing) then; this%dynamic_veg_option = dynamic_veg_option; else; write(*,'(A)') 'ERROR: required entry dynamic_veg_option not found in namelist'; stop; end if - if(snow_albedo_option /= integerMissing) then; this%snow_albedo_option = snow_albedo_option; else; write(*,'(A)') 'ERROR: required entry snow_albedo_option not found in namelist'; stop; end if - if(radiative_transfer_option /= integerMissing) then; this%radiative_transfer_option = radiative_transfer_option; else; write(*,'(A)') 'ERROR: required entry radiative_transfer_option not found in namelist'; stop; end if - if(sfc_drag_coeff_option /= integerMissing) then; this%sfc_drag_coeff_option = sfc_drag_coeff_option; else; write(*,'(A)') 'ERROR: required entry sfc_drag_coeff_option not found in namelist'; stop; end if - if(crop_model_option /= integerMissing) then; this%crop_model_option = crop_model_option; else; write(*,'(A)') 'ERROR: required entry crop_model_option not found in namelist'; stop; end if - if(canopy_stom_resist_option /= integerMissing) then; this%canopy_stom_resist_option = canopy_stom_resist_option; else; write(*,'(A)') 'ERROR: required entry canopy_stom_resist_option not found in namelist'; stop; end if - if(snowsoil_temp_time_option /= integerMissing) then; this%snowsoil_temp_time_option = snowsoil_temp_time_option; else; write(*,'(A)') 'ERROR: required entry snowsoil_temp_time_option not found in namelist'; stop; end if - if(soil_temp_boundary_option /= integerMissing) then; this%soil_temp_boundary_option = soil_temp_boundary_option; else; write(*,'(A)') 'ERROR: required entry soil_temp_boundary_option not found in namelist'; stop; end if - if(supercooled_water_option /= integerMissing) then; this%supercooled_water_option = supercooled_water_option; else; write(*,'(A)') 'ERROR: required entry supercooled_water_option not found in namelist'; stop; end if - if(stomatal_resistance_option /= integerMissing) then; this%stomatal_resistance_option = stomatal_resistance_option; else; write(*,'(A)') 'ERROR: required entry stomatal_resistance_option not found in namelist'; stop; end if - if(evap_srfc_resistance_option /= integerMissing) then; this%evap_srfc_resistance_option = evap_srfc_resistance_option; else; write(*,'(A)') 'ERROR: required entry evap_srfc_resistance_option not found in namelist'; stop; end if - if(subsurface_option /= integerMissing) then; this%subsurface_option = subsurface_option; else; write(*,'(A)') 'ERROR: required entry subsurface_option not found in namelist'; stop; end if + if(zsoil(1) /= realMissing) then; this%zsoil = zsoil; else; call handle_err('ERROR: required entry zsoil not found in namelist'); end if + if(dzsnso(1) /= realMissing) then; this%dzsnso = dzsnso; else; call handle_err('ERROR: required entry dzsnso not found in namelist'); end if + if(sice(1) /= realMissing) then; this%sice = sice; else; call handle_err('ERROR: required entry sice not found in namelist'); end if + if(sh2o(1) /= realMissing) then; this%sh2o = sh2o; else; call handle_err('ERROR: required entry sh2o not found in namelist'); end if + if(zwt /= realMissing) then; this%zwt = zwt; else; call handle_err('ERROR: required entry zwt not found in namelist'); end if + if(precip_phase_option /= integerMissing) then; this%precip_phase_option = precip_phase_option; else; call handle_err('ERROR: required entry precip_phase_option not found in namelist'); end if + if(runoff_option /= integerMissing) then; this%runoff_option = runoff_option; else; call handle_err('ERROR: required entry runoff_option not found in namelist'); end if + if(drainage_option /= integerMissing) then; this%drainage_option = drainage_option; else; call handle_err('ERROR: required entry drainage_option not found in namelist'); end if + if(frozen_soil_option /= integerMissing) then; this%frozen_soil_option = frozen_soil_option; else; call handle_err('ERROR: required entry frozen_soil_option not found in namelist'); end if + if(dynamic_vic_option /= integerMissing) then; this%dynamic_vic_option = dynamic_vic_option; else; call handle_err('ERROR: required entry dynamic_vic_option not found in namelist'); end if + if(dynamic_veg_option /= integerMissing) then; this%dynamic_veg_option = dynamic_veg_option; else; call handle_err('ERROR: required entry dynamic_veg_option not found in namelist'); end if + if(snow_albedo_option /= integerMissing) then; this%snow_albedo_option = snow_albedo_option; else; call handle_err('ERROR: required entry snow_albedo_option not found in namelist'); end if + if(radiative_transfer_option /= integerMissing) then; this%radiative_transfer_option = radiative_transfer_option; else; call handle_err('ERROR: required entry radiative_transfer_option not found in namelist'); end if + if(sfc_drag_coeff_option /= integerMissing) then; this%sfc_drag_coeff_option = sfc_drag_coeff_option; else; call handle_err('ERROR: required entry sfc_drag_coeff_option not found in namelist'); end if + if(crop_model_option /= integerMissing) then; this%crop_model_option = crop_model_option; else; call handle_err('ERROR: required entry crop_model_option not found in namelist'); end if + if(canopy_stom_resist_option /= integerMissing) then; this%canopy_stom_resist_option = canopy_stom_resist_option; else; call handle_err('ERROR: required entry canopy_stom_resist_option not found in namelist'); end if + if(snowsoil_temp_time_option /= integerMissing) then; this%snowsoil_temp_time_option = snowsoil_temp_time_option; else; call handle_err('ERROR: required entry snowsoil_temp_time_option not found in namelist'); end if + if(soil_temp_boundary_option /= integerMissing) then; this%soil_temp_boundary_option = soil_temp_boundary_option; else; call handle_err('ERROR: required entry soil_temp_boundary_option not found in namelist'); stop; end if + if(supercooled_water_option /= integerMissing) then; this%supercooled_water_option = supercooled_water_option; else; call handle_err('ERROR: required entry supercooled_water_option not found in namelist'); stop; end if + if(stomatal_resistance_option /= integerMissing) then; this%stomatal_resistance_option = stomatal_resistance_option; else; call handle_err('ERROR: required entry stomatal_resistance_option not found in namelist'); stop; end if + if(evap_srfc_resistance_option /= integerMissing) then; this%evap_srfc_resistance_option = evap_srfc_resistance_option; else; call handle_err('ERROR: required entry evap_srfc_resistance_option not found in namelist'); stop; end if + if(subsurface_option /= integerMissing) then; this%subsurface_option = subsurface_option; else; call handle_err('ERROR: required entry subsurface_option not found in namelist'); stop; end if ! store missing values as well this%integerMissing = integerMissing @@ -360,4 +368,15 @@ subroutine ReadNamelist(this, namelist_file) end subroutine ReadNamelist + SUBROUTINE handle_err(message) + implicit none + character(*),intent(in) :: message ! error message + call write_log(trim(message)// ' ..STOPPING', LOG_LEVEL_FATAL) + write(*,'(A)') 'FATAL '//trim(message) + call flush(6) + stop + + END SUBROUTINE handle_err + + end module NamelistRead diff --git a/src/ParametersRead.f90 b/src/ParametersRead.f90 index 0f04f0c6..803e361c 100644 --- a/src/ParametersRead.f90 +++ b/src/ParametersRead.f90 @@ -1,4 +1,5 @@ MODULE ParametersRead + use noahowp_log_module ! Parameter table read routines: ! Adapted from the original module_sf_noahmplsm.F module with several modifications @@ -621,6 +622,7 @@ SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, soil_class if (ierr/=0) then write(message,fmt='(A)') 'ParametersRead.f90: read_soil_parameters: failure opening SOILPARM.TBL' + call write_log(message, LOG_LEVEL_WARNING) call handle_err(ierr, message) end if @@ -655,6 +657,7 @@ SUBROUTINE read_soil_parameters(param_dir, soil_table, general_table, soil_class end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_soil_parameters: failure opening GENPARM.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_soil_parameters: failure opening GENPARM.TBL') end if @@ -731,6 +734,7 @@ SUBROUTINE read_rad_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_rad_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_rad_parameters: Cannot find file MPTABLE.TBL') endif @@ -800,6 +804,7 @@ subroutine read_global_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_global_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_global_parameters: Cannot find file MPTABLE.TBL') endif @@ -980,6 +985,7 @@ SUBROUTINE read_crop_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_crop_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_crop_parameters: Cannot find file MPTABLE.TBL') endif @@ -1164,6 +1170,7 @@ SUBROUTINE read_irrigation_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_irrigation_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_irrigation_parameters: Cannot find file MPTABLE.TBL') endif @@ -1223,6 +1230,7 @@ SUBROUTINE read_tiledrain_parameters(param_dir, noahowp_table) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_tiledrain_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_tiledrain_parameters: Cannot find file MPTABLE.TBL') endif read(15,tiledrain_parameters) @@ -1277,6 +1285,7 @@ SUBROUTINE read_optional_parameters(param_dir, noahowp_table) end if if (ierr /= 0) then + call write_log('ParametersRead.f90: read_optional_parameters: Cannot find file MPTABLE.TBL', LOG_LEVEL_WARNING) call handle_err(ierr, 'ParametersRead.f90: read_optional_parameters: Cannot find file MPTABLE.TBL') endif @@ -1291,6 +1300,7 @@ SUBROUTINE handle_err(err,message) integer, intent(in) :: err ! error code character(*),intent(in) :: message ! error message if(err/=0)then + call write_log('FATAL ERROR: '//trim(message)// ' ..STOPPING', LOG_LEVEL_FATAL) write(*,*) 'FATAL ERROR: '//trim(message) call flush(6) stop diff --git a/src/RunModule.f90 b/src/RunModule.f90 index cb357b84..9d5d3240 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/SnowSoilTempModule.f90 b/src/SnowSoilTempModule.f90 index bb5bbb82..ac4736de 100644 --- a/src/SnowSoilTempModule.f90 +++ b/src/SnowSoilTempModule.f90 @@ -3,6 +3,7 @@ module SnowSoilTempModule + use noahowp_log_module use LevelsType use DomainType use ParametersType @@ -109,9 +110,13 @@ SUBROUTINE TSNOSOI (parameters, levels, domain, options, forcing, & ! in IF (ABS(ERR_EST) > 1.) THEN ! W/m2 WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy', ERR_EST,' W/m2' + call write_log('TSNOSOI is losing(-)/gaining(+) false energy : '//rtoa(ERR_EST)//' W/m2', LOG_LEVEL_WARNING) !call wrf_message(trim(message)) WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') & domain%ILOC, domain%JLOC, domain%IST, ERR_EST, SSOIL, SNOWH, TG, STC(ISNOW+1), EFLXB + + call write_log('domain%ILOC :'//itoa(domain%ILOC) //", domain%JLOC : "//itoa(domain%JLOC), LOG_LEVEL_INFO) + call writelog('SSOIL : '//rtoa(SSOIL)//', SNOWH : '//rtoa(SNOWH)//', TG: '//rtoa(TG), "INFO") !call wrf_message(trim(message)) !niu STOP END IF @@ -649,4 +654,4 @@ SUBROUTINE FRH2O (parameters, ISOIL, TKELV, SMC, SH2O, FREE) ! FREE is output END SUBROUTINE FRH2O -END module SnowSoilTempModule \ No newline at end of file +END module SnowSoilTempModule diff --git a/src/StateSerialization.f90 b/src/StateSerialization.f90 new file mode 100644 index 00000000..ea4a092a --- /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/UtilitiesModule.f90 b/src/UtilitiesModule.f90 index 6af6cb15..40dc0a3c 100644 --- a/src/UtilitiesModule.f90 +++ b/src/UtilitiesModule.f90 @@ -10,6 +10,8 @@ module UtilitiesModule use DomainType use EnergyType use ForcingType + use noahowp_log_module + implicit none contains @@ -180,36 +182,43 @@ subroutine geth_newdate (odate, idt, & ! in ! Check that the month of ODATE makes sense. if ((moold > 12).or.(moold < 1)) then write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold + call write_log("UtilitiesModule: Invalid month of ODATE: "//itoa(moold), LOG_LEVEL_WARNING) opass = .FALSE. end if ! Check that the day of ODATE makes sense. if ((dyold > mday(moold)).or.(dyold < 1)) then write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold + call write_log("UtilitiesModule: Invalid day of ODATE: "//itoa(dyold), LOG_LEVEL_WARNING) opass = .FALSE. end if ! Check that the hour of ODATE makes sense. if ((hrold > 23).or.(hrold < 0)) then write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold + call write_log("UtilitiesModule: Invalid hour of ODATE: "//itoa(hrold), LOG_LEVEL_WARNING) opass = .FALSE. end if ! Check that the minute of ODATE makes sense. if ((miold > 59).or.(miold < 0)) then write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold + call write_log("UtilitiesModule: Invalid minute of ODATE: "//itoa(miold), LOG_LEVEL_WARNING) opass = .FALSE. end if ! Check that the second of ODATE makes sense. if ((scold > 59).or.(scold < 0)) then write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold + call write_log("UtilitiesModule: Invalid second of ODATE: "//itoa(scold), LOG_LEVEL_WARNING) opass = .FALSE. end if ! If opass = false, then cancel the run if (.not.opass) then write(*,*) 'Crazy ODATE: ', odate(1:olen), olen + call write_log("UtilitiesModule: Crazy ODATE: "//odate(1:olen)//", "//itoa(olen), LOG_LEVEL_WARNING) + call write_log("ABORTING ..", LOG_LEVEL_FATAL) call abort() end if @@ -261,6 +270,8 @@ subroutine geth_newdate (odate, idt, & ! in write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & olen write(*,*) odate(1:olen) + call write_log("UtilitiesModul: GETH_NEWDATE: Strange length for ODATE" //odate(1:olen), LOG_LEVEL_WARNING) + call write_log("UtilitiesModul: ABORTING ...", LOG_LEVEL_FATAL) call abort() end if @@ -408,6 +419,7 @@ subroutine geth_newdate (odate, idt, & ! in else stop "DATELEN PROBLEM" + call write_log("UtilitiesModule: geth_newdate: DATELEN PROBLEM. STOPPING ..", LOG_LEVEL_FATAL) end if endif @@ -457,6 +469,7 @@ subroutine geth_idts (newdate, olddate, idt) nlen = len(newdate) if (nlen /= olen) then write(*,'("GETH_IDTS: NLEN /= OLEN: ", A, 3x, A)') newdate(1:nlen), olddate(1:olen) + call write_log("UtilitiesModule: GETH_IDTS: NLEN /= OLEN. ABORTING..", LOG_LEVEL_FATAL) call abort endif @@ -596,13 +609,13 @@ subroutine geth_idts (newdate, olddate, idt) ! Check that the month of NDATE makes sense. if ((monew > 12).or.(monew < 1)) then - print*, 'GETH_IDTS: Month of NDATE = ', monew + call write_log("GETH_IDTS: Invalid Month of NDATE = " //itoa(monew), LOG_LEVEL_WARNING) npass = .false. end if ! Check that the month of ODATE makes sense. if ((moold > 12).or.(moold < 1)) then - print*, 'GETH_IDTS: Month of ODATE = ', moold + call write_log("GETH_IDTS: Invalid Month of ODATE = " //itoa(moold), LOG_LEVEL_WARNING) opass = .false. end if @@ -610,13 +623,13 @@ subroutine geth_idts (newdate, olddate, idt) if (monew /= 2) then ! ...... For all months but February if ((dynew > mday(monew)).or.(dynew < 1)) then - print*, 'GETH_IDTS: Day of NDATE = ', dynew + call write_log("GETH_IDTS: Invalid Day of NDATE = " //itoa(dynew), LOG_LEVEL_WARNING) npass = .false. end if else if (monew == 2) then ! ...... For February if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then - print*, 'GETH_IDTS: Day of NDATE = ', dynew + call write_log("GETH_IDTS: Invalid Day of NDATE for February = " //itoa(dynew), LOG_LEVEL_WARNING) npass = .false. end if endif @@ -625,60 +638,60 @@ subroutine geth_idts (newdate, olddate, idt) if (moold /= 2) then ! ...... For all months but February if ((dyold > mday(moold)).or.(dyold < 1)) then - print*, 'GETH_IDTS: Day of ODATE = ', dyold + call write_log("GETH_IDTS: Invalid Day of ODATE = " //itoa(dyold), LOG_LEVEL_WARNING) opass = .false. end if else if (moold == 2) then ! ....... For February if ((dyold > nfeb(yrold)).or.(dyold < 1)) then - print*, 'GETH_IDTS: Day of ODATE = ', dyold + call write_log("GETH_IDTS: Invalid Day of ODATE for February = " //itoa(dyold), LOG_LEVEL_WARNING) opass = .false. end if end if ! Check that the hour of NDATE makes sense. if ((hrnew > 23).or.(hrnew < 0)) then - print*, 'GETH_IDTS: Hour of NDATE = ', hrnew + call write_log("GETH_IDTS: Invalid Hour of NDATE = " //itoa(hrnew), LOG_LEVEL_WARNING) npass = .false. end if ! Check that the hour of ODATE makes sense. if ((hrold > 23).or.(hrold < 0)) then - print*, 'GETH_IDTS: Hour of ODATE = ', hrold + call write_log("GETH_IDTS: Invalid Hour of ODATE = " //itoa(hrold), LOG_LEVEL_WARNING) opass = .false. end if ! Check that the minute of NDATE makes sense. if ((minew > 59).or.(minew < 0)) then - print*, 'GETH_IDTS: Minute of NDATE = ', minew + call write_log("GETH_IDTS: Invalid Minute of NDATE = " //itoa(minew), LOG_LEVEL_WARNING) npass = .false. end if ! Check that the minute of ODATE makes sense. if ((miold > 59).or.(miold < 0)) then - print*, 'GETH_IDTS: Minute of ODATE = ', miold + call write_log("GETH_IDTS: Invalid Minute of ODATE = " //itoa(miold), LOG_LEVEL_WARNING) opass = .false. end if ! Check that the second of NDATE makes sense. if ((scnew > 59).or.(scnew < 0)) then - print*, 'GETH_IDTS: SECOND of NDATE = ', scnew + call write_log("GETH_IDTS: Invalid Second of NDATE = " //itoa(scnew), LOG_LEVEL_WARNING) npass = .false. end if ! Check that the second of ODATE makes sense. if ((scold > 59).or.(scold < 0)) then - print*, 'GETH_IDTS: Second of ODATE = ', scold + call write_log("GETH_IDTS: Invalid Second of ODATE = " //itoa(scold), LOG_LEVEL_WARNING) opass = .false. end if if (.not. npass) then - print*, 'Screwy NDATE: ', ndate(1:nlen) + call write_log("Screwy NDATE = " //ndate(1:nlen)//" ABORTING..", LOG_LEVEL_FATAL) call abort() end if if (.not. opass) then - print*, 'Screwy ODATE: ', odate(1:olen) + call write_log("Screwy ODATE = " //odate(1:olen)//" ABORTING..", LOG_LEVEL_FATAL) call abort() end if @@ -922,4 +935,4 @@ SUBROUTINE calc_declin (nowdate, & ! in END SUBROUTINE calc_declin -end module UtilitiesModule \ No newline at end of file +end module UtilitiesModule diff --git a/src/byte_utilities.f90 b/src/byte_utilities.f90 new file mode 100644 index 00000000..fb3e2e9f --- /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 00000000..1d4c2a5e --- /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 00000000..fa2394a6 --- /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 00000000..e3044e1e --- /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 diff --git a/src/noahowpLogger.f90 b/src/noahowpLogger.f90 new file mode 100644 index 00000000..8145f339 --- /dev/null +++ b/src/noahowpLogger.f90 @@ -0,0 +1,339 @@ +module noahowp_log_module + implicit none + private + public :: write_log, is_logger_enabled, get_log_level, itoa, rtoa + public :: LOG_LEVEL_DEBUG, LOG_LEVEL_INFO, LOG_LEVEL_WARNING, LOG_LEVEL_SEVERE, LOG_LEVEL_FATAL + + ! Log levels (made public so other modules can use them) + integer, parameter :: LOG_LEVEL_DEBUG = 1 + integer, parameter :: LOG_LEVEL_INFO = 2 + integer, parameter :: LOG_LEVEL_WARNING = 3 + integer, parameter :: LOG_LEVEL_SEVERE = 4 + integer, parameter :: LOG_LEVEL_FATAL = 5 + + integer :: log_level = LOG_LEVEL_INFO + + character(len=1024) :: log_file_path + integer :: log_unit = 12 + logical :: logging_enabled = .false. + logical :: opened_once = .false. + logical :: logger_initialized = .false. ! Flag to track if the logger has been initialized + + ! To use Logger while running this module stand-alone, set + ! the following environment variables, case-sensitive: + ! NGEN_EWTS_LOGGING=ENABLED + ! NGEN_LOG_FILE_PATH= + ! NOAHOWP_LOGLEVEL= + ! + ! Constants character(len=1), parameter :: DS = "/" + character(len=16), parameter :: MODULE_NAME = "Noah-OWP-Modular" + character(len=14), parameter :: LOG_DIR_NGENCERF = "/ngencerf/data" + character(len=8), parameter :: LOG_DIR_DEFAULT = "run-logs" + character(len=3), parameter :: LOG_FILE_EXT = "log" + character(len=1), parameter :: DS = "/" + character(len=17), parameter :: EV_EWTS_LOGGING = "NGEN_EWTS_LOGGING" + character(len=18), parameter :: EV_NGEN_LOGFILEPATH = "NGEN_LOG_FILE_PATH" + character(len=19), parameter :: EV_MODULE_LOGFILEPATH = "NOAHOWP_LOGFILEPATH" + character(len=16), parameter :: EV_MODULE_LOGLEVEL = "NOAHOWP_LOGLEVEL" + character(len=7), parameter :: log_module_name = "NOAHOWP" + integer, parameter :: LOG_MODULE_NAME_LEN = 8 ! // Width of module name for log entries + integer, parameter :: LOG_ENTRY_LEVEL_LEN = 7 ! // Width of log level for log entries + +contains + + subroutine initialize_logger() + character(len=256) :: log_env, log_str + integer :: save_log_level + + logger_initialized = .true. + call get_env_var(EV_EWTS_LOGGING, log_env) + if (trim(log_env) == "ENABLED") then + logging_enabled = .true. + print *,trim(MODULE_NAME)," Logging ", trim(log_env) + call flush(6) + else + logging_enabled = .false. + print *,trim(MODULE_NAME)," Logging NOT enabled. EV_EWTS_LOGGING=", trim(log_env) + call flush(6) + return + end if + ! Here because return was not executed above + + ! Set log level from environment variable (if exists) + call get_env_var(EV_MODULE_LOGLEVEL, log_env) + log_str = trim(log_env) + if (log_str == "DEBUG" ) then + log_level = LOG_LEVEL_DEBUG + else if (log_str == "INFO" ) then + log_level = LOG_LEVEL_INFO + else if (log_str == "WARNING" ) then + log_level = LOG_LEVEL_WARNING + else if (log_str == "SEVERE" ) then + log_level = LOG_LEVEL_SEVERE + else if (log_str == "FATAL" ) then + log_level = LOG_LEVEL_FATAL + else + log_str = "INFO (" // trim(EV_MODULE_LOGLEVEL) // " = '" // trim(log_str) // "' INVALID Log Level) Defaulted to INFO" + log_level = LOG_LEVEL_INFO ! Default level + end if + + ! Get the log file path by calling set_log_file_path + call set_log_file_path() + + print *, trim(MODULE_NAME)," Log level: ", log_str + call flush(6) + end subroutine initialize_logger + + function fit_string(str, target_len) result(fixed_str) + implicit none + character(len=*), intent(in) :: str + integer, intent(in) :: target_len + character(len=target_len) :: fixed_str + integer :: copy_len + + ! Determine how many characters to copy (min of source or target length) + copy_len = min(len_trim(str), target_len) + + ! Copy the appropriate number of characters, right pad with spaces automatically + fixed_str = ' ' ! Initialize to spaces + fixed_str(1:copy_len) = str(1:copy_len) + end function fit_string + + subroutine write_log(message, msg_level) + character(len=*), intent(in) :: message + integer, intent (in) :: msg_level + character(len=40) :: timestamp, log_level_str + character(len=LOG_MODULE_NAME_LEN) :: fixed_tag + character(len=LOG_ENTRY_LEVEL_LEN) :: fixed_lvl + character(len=1100) :: log_msg + + if (.not. logger_initialized) then + call initialize_logger() + end if + + if (logging_enabled .and. (msg_level >= log_level)) then + ! Convert log level to a string + if (msg_level == LOG_LEVEL_DEBUG ) then + log_level_str = "DEBUG" + elseif (msg_level == LOG_LEVEL_INFO ) then + log_level_str = "INFO" + elseif (msg_level == LOG_LEVEL_WARNING ) then + log_level_str = "WARNING" + elseif (msg_level == LOG_LEVEL_SEVERE ) then + log_level_str = "SEVERE" + elseif (msg_level == LOG_LEVEL_FATAL ) then + log_level_str = "FATAL" + else + ! If the level is unknown, ignore logging + return + end if + + ! Log the message + call create_timestamp(.false., .true., .true., timestamp) + fixed_tag = fit_string(log_module_name, LOG_MODULE_NAME_LEN) + fixed_lvl = fit_string(log_level_str,LOG_ENTRY_LEVEL_LEN) + log_msg = trim(timestamp) // " " // fixed_tag // " " // fixed_lvl // " " // trim(message) + if (log_file_ready(.true.)) then + write(log_unit, '(A)') trim(log_msg) + else + print *, log_msg + call flush(6) + end if + close(log_unit) ! Since this is a shared file with other modules, need to close this acces after each write + end if + end subroutine write_log + + subroutine create_timestamp(date_only, iso, append_ms, timestamp) + logical, intent(in) :: date_only + logical, intent(in) :: iso + logical, intent(in) :: append_ms + character(len=*), intent(out) :: timestamp + + integer :: values(8) + character(len=32) :: ts_base, ms_str + + call date_and_time(values=values) + + if (date_only) then + write(ts_base, '(I4.4,I2.2,I2.2)') & + values(1), values(2), values(3) + else if (iso) then + write(ts_base, '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)') & + values(1), values(2), values(3), values(5), values(6), values(7) + else + write(ts_base, '(I4.4,I2.2,I2.2,"T",I2.2,I2.2,I2.2)') & + values(1), values(2), values(3), values(5), values(6), values(7) + end if + + if (append_ms) then + write(ms_str, '(".",I3.3)') values(8) + timestamp = trim(ts_base) // trim(ms_str) + else + timestamp = trim(ts_base) + end if + end subroutine create_timestamp + + ! Check if a directory exists + logical function directory_exists(path) + character(len=*), intent(in) :: path + integer :: status + character(len=522) :: cmd + + cmd = "test -d " // path + call execute_command_line(cmd, exitstat=status) + directory_exists = (status == 0) + end function directory_exists + + ! Create directory if it doesn't exist + logical function create_directory(path) + character(len=*), intent(in) :: path + character(len=522) :: cmd + integer :: status + + if (.not. directory_exists(path)) then + cmd = "mkdir -p " // path + call execute_command_line(cmd, exitstat=status) + create_directory = (status == 0) + else + create_directory = .true. + end if + end function create_directory + + ! Set the log file path based on environment variables or defaults + subroutine set_log_file_path() + character(len=256) :: env_var + logical :: append_entries + logical :: module_log_env_exists + character(len=512) :: log_file_dir + character(len=40) :: timestamp + integer :: save_log_level + + append_entries = .true. + module_log_env_exists = .false. + ! Check if module log path environment exists + call get_env_var(EV_MODULE_LOGFILEPATH, env_var) + if (trim(adjustl(env_var)) /= "") then + log_file_path = trim(env_var) + module_log_env_exists = .true. + else + ! log file path not set yet + call get_env_var(EV_NGEN_LOGFILEPATH, env_var) + if (trim(adjustl(env_var)) /= "") then + log_file_path = trim(env_var) + else + ! ngen log path does not exist. Create alternate log + append_entries = .false. + ! Determine parent dir + if (directory_exists(LOG_DIR_NGENCERF)) then + log_file_dir = trim(LOG_DIR_NGENCERF) // DS // trim(LOG_DIR_DEFAULT) + else + call get_env_var("HOME", env_var) + if (trim(adjustl(env_var)) /= "") then + log_file_dir = trim(env_var) // DS // trim(LOG_DIR_DEFAULT) + else + log_file_dir = "~" // DS // trim(LOG_DIR_DEFAULT) + end if + end if + ! Ensure parent log dir exists + if (create_directory(log_file_dir)) then + ! Get dir for this log + call get_env_var("USER", env_var) + if (trim(adjustl(env_var)) /= "") then + log_file_dir = trim(log_file_dir) // DS // trim(env_var) + else + ! Get a date only timestamp + call create_timestamp(.true., .false., .false., timestamp) + log_file_dir = trim(log_file_dir) // DS // trim(timestamp) + end if + if (create_directory(log_file_dir)) then + ! Set log file name with T