diff --git a/CMakeLists.txt b/CMakeLists.txt index ef52a34..37edb4d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,9 +2,12 @@ cmake_minimum_required(VERSION 3.12) enable_language( Fortran ) add_subdirectory(../iso_c_fortran_bmi ${CMAKE_BINARY_DIR}/iso_c_bmi) +set( CMAKE_VERBOSE_MAKEFILE on ) + list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/../../cmake/") # Uncomment this and rebuild artifacts to enable debugging #set(CMAKE_BUILD_TYPE Debug) + add_compile_options( "-Wall" "$<$:-g;-fbacktrace;-fbounds-check>" @@ -63,7 +66,8 @@ set(MODEL_SOURCE_DIR src/) set(BMI_SOURCE_DIR src/bmi/) file(GLOB BMI_SOURCE ${BMI_SOURCE_DIR}*.f90) -file( GLOB MODEL_SOURCES ${MODEL_SOURCE_DIR}/snow19/*.f ${MODEL_SOURCE_DIR}/driver/*.f90 ${MODEL_SOURCE_DIR}/share/*.f90) +#file( GLOB MODEL_SOURCES ${MODEL_SOURCE_DIR}/snow19/*.f ${MODEL_SOURCE_DIR}/driver/*.f90 ${MODEL_SOURCE_DIR}/share/*.f90) +file( GLOB MODEL_SOURCES ${MODEL_SOURCE_DIR}/snow19/*.f ${MODEL_SOURCE_DIR}/share/*.f90 ${MODEL_SOURCE_DIR}/driver/*.f90 ${CMAKE_CURRENT_LIST_DIR}/../datetime-fortran-1.7.0/src/*.f90) if(WIN32) add_library(snow17bmi ${BMI_SOURCE} ) @@ -72,16 +76,19 @@ else() endif() #target_include_directories(snow17bmi PUBLIC ${netCDF_INCLUDE_DIR} ${netCDF_MOD_PATH}) # netcdf not needed for this code -target_include_directories( snow17bmi PUBLIC ) +#target_include_directories( snow17bmi PUBLIC ${FDATETIME_INCLUDE_DIRS} ) #We know we are building this for NGEN support, so define the preprocessor directive in the compile options #Not sure why the global target_compile_options(snow17bmi PUBLIC -cpp -ffree-line-length-none) +#target_compile_options(snow17bmi PUBLIC -O3 -fdefault-real-8 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all) ##### NETCDF ##### #target_link_libraries( snow17bmi iso_c_bmi ${netCDF_C_LIB} ${netCDF_FORTRAN_LIB}) ##### END NETCDF ##### +#target_link_libraries( snow17bmi PUBLIC iso_c_bmi fortran_stdlib::fortran_stdlib ${FDATETIME_LIBRARIES} ) target_link_libraries( snow17bmi PUBLIC iso_c_bmi ) + set_target_properties(snow17bmi PROPERTIES VERSION ${PROJECT_VERSION}) include(GNUInstallDirs) diff --git a/INSTALL.md b/INSTALL.md index 3115705..0c35ea8 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -22,4 +22,30 @@ cd ../output/ # to view output data ``` Note that the ex1/ example is part of the repo. The unpacked directory and test contents will not be included in a push back to the online repo. To the program for other purposes, create new input files and output directories outside of the `snow17/` repository directory, and link to the executable in `snow17/bin/`. +## 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 SNOW17_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. diff --git a/LICENSE b/LICENSE index d645695..01fbb8d 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/build/Makefile b/build/Makefile index 16479e6..bcc8325 100644 --- a/build/Makefile +++ b/build/Makefile @@ -1,146 +1,163 @@ #======================================================================== # Makefile to compile the Snow-17 and driver code for multi-zone model #======================================================================== - + #======================================================================== # PART 1: Define directory paths and compiler - + # Define main/top directory (parent of /build/) # Note: the relative path of "../" drops into snow17 parent directory F_MASTER_DIR = ../ - +DATETIME_FORTRAN_INSTALLATION_DIR=../../../extern + # Location of the compiled modules # MOD_PATH = $(F_MASTER_DIR)/build/ -- not used - + # Define directories driver_dir = $(F_MASTER_DIR)/src/driver/ snow19_dir = $(F_MASTER_DIR)/src/snow19/ share_dir = $(F_MASTER_DIR)/src/share/ bmi_dir = $(F_MASTER_DIR)/src/bmi/ exe_dir = $(F_MASTER_DIR)/bin/ - +fdatetime_dir = $(DATETIME_FORTRAN_INSTALLATION_DIR)/datetime-fortran-1.7.0/src/ + # Define the executable and path EXE = $(exe_dir)/snow17.exe - + # Define your Fortran compiler #FC = pgf90 #FC = ifort FC = gfortran - + #======================================================================== # PART 2: Define the libraries and flags (can be an include file) - + # --- Define the libraries and path to include files ifeq "$(FC)" "pgf90" LOCL_PATH = /usr/local - LIB = -L$(LOCL_PATH)/lib + LIB = -L$(LOCL_PATH)/lib INC = -I ./ endif - + ifeq "$(FC)" "gfortran" LOCL_PATH = /usr/local - LIB = -L$(LOCL_PATH)/lib + LIB = -L$(LOCL_PATH)/lib INC = -I ../ endif - + # --- Define flags ifeq "$(FC)" "gfortran" FLAGS_DEBUG = -static -Wall -g -ffree-line-length-none -cpp -fcheck=all - FLAGS = -O3 -fdefault-real-8 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all - FLAGS2 = -O3 -fdefault-real-8 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all + #FLAGS = -O3 -fdefault-real-8 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all + FLAGS = -O3 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all + #FLAGS2 = -O3 -fdefault-real-8 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all + FLAGS2 = -O3 -fno-align-commons -ffree-line-length-none -cpp -fcheck=all endif - + ifeq "$(FC)" "ifort" FLAGS_PROF = -static -debug -warn all -check all -FR -O0 -auto -WB -traceback -g -fltconsistency -fpe0 FLAGS = -O3 -warn all -check all - FLAGS2 = -O3 - FLAGS77 = -O3 -f77rtl + FLAGS2 = -O3 + FLAGS77 = -O3 -f77rtl endif - + ifeq "$(FC)" "pgf90" FLAGS_PROF = -Bstatic -Mbackslash -g -Mchkptr -Mchkstk -Mpgicoff -Minform=inform -Ktrap=divz,inv -Mprof=lines,time # FLAGS = -Mfreeform -O3 -Mbackslash -g -Mchkptr -Mchkstk -Mpgicoff -Minform=inform -Ktrap=divz,inv FLAGS = -O3 -r8 -Kieee FLAGS2 = -O3 -r8 endif - - + + #======================================================================== # PART 3: Assemble all of the various subroutines - + # --- snow-19 code (fortran 90, different options) snow19 = \ - zero19.f \ - rout19.f \ - aesc19.f \ - melt19.f \ - SNEW.f \ - SNOWT.f \ - SNOWPACK.f \ - adjc19.f \ - aeco19.f \ - updt19.f \ - SNDEPTH.f \ - PACK19.f \ - exsnow19.f + zero19.f \ + rout19.f \ + aesc19.f \ + melt19.f \ + SNEW.f \ + SNOWT.f \ + SNOWPACK.f \ + adjc19.f \ + aeco19.f \ + updt19.f \ + SNDEPTH.f \ + PACK19.f \ + exsnow19.f model_snow19 = $(patsubst %, $(snow19_dir)/%, $(snow19)) - - + + # -- share utilities and code used by the driver in running the model run_util = \ - nrtype.f90 \ - constants.f90 \ - namelistModule.f90 \ + snowLogger.f90 \ + nrtype.f90 \ + constants.f90 \ + namelistModule.f90 \ parametersType.f90 \ forcingType.f90 \ dateTimeUtilsModule.f90 \ runInfoType.f90 \ modelVarType.f90 \ ioModule.f90 \ - runSnow17.f90 + byte_utilities.f90 \ + messagepack_value.f90 \ + messagepack_user.f90 \ + messagepack.f90 \ + runSnow17.f90 model_run = $(patsubst %, $(share_dir)/%, $(run_util)) - + # --- BMI functions used by the driver to run the model bmi_functions = bmi.f90 bmi_snow17.f90 snow17_bmi = $(patsubst %, $(bmi_dir)/%, $(bmi_functions)) + +fdatetime_code = datetime_module.f90 +fdatetime = $(patsubst %, $(fdatetime_dir)/%, $(fdatetime_code)) # --- snow17 driver driver_snow17 = driver_bmi.f90 snow17_drv = $(patsubst %, $(driver_dir)/%, $(driver_snow17)) - - + + # --- prepare to stitch it all together # check just using the original names ... this does nothing? run_code = $(model_run) model = $(model_snow19) bmi = $(snow17_bmi) - - + + #======================================================================== -# PART 4: Compile it - -all: model link clean +# PART 4: Compile it + +all: model link clean debug: model_debug link -devel: model link - +devel: model link + check: echo test echo $(FC) - + # compile model code model: - $(FC) $(FLAGS2) -c $(model) $(INC) + #$(FC) $(FLAGS2) -c $(model) $(INC) $(STDLIB_CFLAGS) $(DATETIME_F_CFLAGS) + $(FC) $(FLAGS2) -c $(model) $(fdatetime) $(INC) + #$(FC) $(FLAGS) -c $(run_code) $(bmi) $(snow17_drv) $(INC) $(STDLIB_CFLAGS) $(DATETIME_F_CFLAGS) $(FC) $(FLAGS) -c $(run_code) $(bmi) $(snow17_drv) $(INC) - + model_debug: - $(FC) $(FLAGS2) -g -fcheck=all -c $(model) $(INC) - $(FC) $(FLAGS) -g -fcheck=all -c $(run_code) $(bmi) $(snow17_drv) $(INC) - + #$(FC) $(FLAGS2) -g -fcheck=all -c $(model) $(INC) $(STDLIB_CFLAGS) $(DATETIME_F_CFLAGS) + $(FC) $(FLAGS2) -g -fcheck=all -c $(model) $(fdatetime) $(INC) + #$(FC) $(FLAGS) -g -fcheck=all -c $(run_code) $(bmi) $(snow17_drv) $(INC) $(STDLIB_CFLAGS) $(DATETIME_F_CFLAGS) + (FC) $(FLAGS) -g -fcheck=all -c $(run_code) $(bmi) $(snow17_drv) $(INC) + # link routines link: -# $(FC) -fPIC -Bstatic_pgi -rpath,/usr/local/netcdf4-pgi/lib *.o -I./ $(LIBNETCDF) -o $(EXE) - $(FC) -fPIC -I./ $(LIB) -o $(EXE) *.o - +# $(FC) -fPIC -Bstatic_pgi -rpath,/usr/local/netcdf4-pgi/lib *.o -I./ $(LIBNETCDF) -o $(EXE) + #$(FC) -fPIC -I./ $(LIB) -o $(EXE) *.o $(STDLIB_LIBS) $(DATETIME_F_LIBS) + $(FC) -fPIC -I./ $(LIB) -o $(EXE) *.o + # Remove object files clean: rm -f *.o diff --git a/src/bmi/bmi_snow17.f90 b/src/bmi/bmi_snow17.f90 index ec9b054..92f931d 100644 --- a/src/bmi/bmi_snow17.f90 +++ b/src/bmi/bmi_snow17.f90 @@ -7,7 +7,7 @@ module bmi_snow17_module #else use bmif_2_0 #endif - + use snow_log_module use runModule use, intrinsic :: iso_c_binding, only: c_ptr, c_loc, c_f_pointer implicit none @@ -175,6 +175,7 @@ function snow17_initialize(this, config_file) result (bmi_status) !else !call initialize_from_defaults(this%model) end if + call write_log("Initialization Done!", LOG_LEVEL_INFO) bmi_status = BMI_SUCCESS end function snow17_initialize @@ -263,6 +264,7 @@ function snow17_update_until(this, time) result (bmi_status) ! check to see if desired time to advance to is earlier than current time (can't go backwards) if (time < this%model%runinfo%curr_datetime) then bmi_status = BMI_FAILURE + call write_log("check to see if desired time to advance to is earlier than current time", LOG_LEVEL_SEVERE) return end if ! otherwise try to advance to end time @@ -287,8 +289,19 @@ function snow17_var_grid(this, name, grid) result (bmi_status) 'precip_scf', 'sneqv', 'snowh', 'raim') ! output vars grid = 0 bmi_status = BMI_SUCCESS + case('scf', 'mfmax', 'mfmin', 'uadj', 'si', & ! parameters + 'pxtemp', 'nmf', 'tipm', 'mbase', 'plwhc', & + 'daygm', 'adc','elev', 'latitude', & + 'hru_area', 'hru_id', 'total_area') + grid = 0 + bmi_status = BMI_SUCCESS + case('adc1', 'adc2', 'adc3', 'adc4', 'adc5', & ! parameters + 'adc6', 'adc7', 'adc8', 'adc9', 'adc10', 'adc11') + grid = 0 + bmi_status = BMI_SUCCESS case default grid = -1 + call write_log("snow17_var_grid - " // name // " not found.", LOG_LEVEL_SEVERE) bmi_status = BMI_FAILURE end select end function snow17_var_grid @@ -310,6 +323,7 @@ function snow17_grid_type(this, grid, type) result (bmi_status) ! bmi_status = BMI_SUCCESS case default type = "-" + call write_log("snow17_grid_type - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) bmi_status = BMI_FAILURE end select end function snow17_grid_type @@ -332,6 +346,7 @@ function snow17_grid_rank(this, grid, rank) result (bmi_status) case default rank = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_rank - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_rank @@ -351,6 +366,7 @@ function snow17_grid_shape(this, grid, shape) result (bmi_status) case default shape(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_shape - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_shape @@ -372,6 +388,7 @@ function snow17_grid_size(this, grid, size) result (bmi_status) case default size = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_size - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_size @@ -391,6 +408,7 @@ function snow17_grid_spacing(this, grid, spacing) result (bmi_status) case default spacing(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_grid_spacing - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_spacing ! @@ -410,6 +428,7 @@ function snow17_grid_origin(this, grid, origin) result (bmi_status) case default origin(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_grid_apacing - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_origin @@ -427,6 +446,7 @@ function snow17_grid_x(this, grid, x) result (bmi_status) case default x(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_grid_x - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_x @@ -444,6 +464,7 @@ function snow17_grid_y(this, grid, y) result (bmi_status) case default y(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_grid_y - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_y @@ -461,6 +482,7 @@ function snow17_grid_z(this, grid, z) result (bmi_status) case default z(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_grid_z - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_z @@ -477,6 +499,7 @@ function snow17_grid_node_count(this, grid, count) result(bmi_status) case default count = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_node_count - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_grid_node_count @@ -489,6 +512,7 @@ function snow17_grid_edge_count(this, grid, count) result(bmi_status) count = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_edge_count - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_edge_count ! Get the number of faces in an unstructured grid. @@ -500,6 +524,7 @@ function snow17_grid_face_count(this, grid, count) result(bmi_status) count = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_face_count - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_face_count ! Get the edge-node connectivity. @@ -511,6 +536,7 @@ function snow17_grid_edge_nodes(this, grid, edge_nodes) result(bmi_status) edge_nodes(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_edge_nodes - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_edge_nodes ! Get the face-edge connectivity. @@ -522,6 +548,7 @@ function snow17_grid_face_edges(this, grid, face_edges) result(bmi_status) face_edges(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_face_edges - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_face_edges ! Get the face-node connectivity. @@ -533,6 +560,7 @@ function snow17_grid_face_nodes(this, grid, face_nodes) result(bmi_status) face_nodes(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_face_nodes - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_face_nodes ! Get the number of nodes for each face. @@ -544,6 +572,7 @@ function snow17_grid_nodes_per_face(this, grid, nodes_per_face) result(bmi_statu nodes_per_face(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_grid_nodes_per_face - " // itoa(grid) // " not found.", LOG_LEVEL_SEVERE) end function snow17_grid_nodes_per_face ! The data type of the variable, as a string. @@ -552,15 +581,45 @@ function snow17_var_type(this, name, type) result (bmi_status) character (len=*), intent(in) :: name character (len=*), intent(out) :: type integer :: bmi_status + character(len=BMI_MAX_TYPE_NAME) :: ser_create = "uint64" !pads spaces upto 2048. + character(len=BMI_MAX_TYPE_NAME) :: ser_size = "uint64" !pads spaces upto 2048 + character(len=BMI_MAX_TYPE_NAME) :: ser_state = "character" !pads spaces upto 2048 + character(len=BMI_MAX_TYPE_NAME) :: ser_free = "int" !pads spaces upto 2048 select case(name) case('tair', 'precip', & ! input/output vars 'precip_scf', 'sneqv', 'snowh', 'raim') ! output vars type = "real" bmi_status = BMI_SUCCESS + case('scf', 'mfmax', 'mfmin', 'uadj', 'si', & ! parameters + 'pxtemp', 'nmf', 'tipm', 'mbase', 'plwhc', & + 'daygm', 'adc','elev', 'latitude', & + 'hru_area', 'total_area') + type = "real" + bmi_status = BMI_SUCCESS + case('adc1', 'adc2', 'adc3', 'adc4', 'adc5', & ! parameters + 'adc6', 'adc7', 'adc8', 'adc9', 'adc10', 'adc11') + type = "real" + bmi_status = BMI_SUCCESS + case('hru_id') + type = "character" + bmi_status = BMI_SUCCESS + case ('serialization_create') + type = ser_create + bmi_status = BMI_SUCCESS + case ('serialization_size') + type = ser_size + bmi_status = BMI_SUCCESS + case ('serialization_state') + type = ser_state + bmi_status = BMI_SUCCESS + case ('serialization_free') + type = ser_free + bmi_status = BMI_SUCCESS case default type = "-" bmi_status = BMI_FAILURE + call write_log("snow17_var_type - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_var_type @@ -590,9 +649,22 @@ function snow17_var_units(this, name, units) result (bmi_status) case("raim") units = "mm/s" bmi_status = BMI_SUCCESS + case("elev") + units = "mm/s" + bmi_status = BMI_SUCCESS + case("hru_area", "total_area") + units = "km**2" + bmi_status = BMI_SUCCESS + case("adc", "scf", "mfmax", "mfmin", "uadj", "si", "pxtemp", "nmf", "tipm", "mbase", "plwhc", "daygm") + units = "unitless" + bmi_status = BMI_SUCCESS + case('adc1', 'adc2', 'adc3', 'adc4', 'adc5', 'adc6', 'adc7', 'adc8', 'adc9', 'adc10', 'adc11') + units = "unitless" + bmi_status = BMI_SUCCESS case default units = "-" bmi_status = BMI_FAILURE + call write_log("snow17_var_unit - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_var_units @@ -606,7 +678,9 @@ function snow17_var_itemsize(this, name, size) result (bmi_status) ! note: the combined variables are used assuming ngen is interacting with the ! catchment-averaged result if snowbands are used + select case(name) + case("precip") size = sizeof(this%model%forcing%precip(1)) ! 'sizeof' in gcc & ifort bmi_status = BMI_SUCCESS @@ -625,9 +699,91 @@ function snow17_var_itemsize(this, name, size) result (bmi_status) case("raim") size = sizeof(this%model%modelvar%raim_comb) bmi_status = BMI_SUCCESS + case("hru_id") + size = sizeof(this%model%parameters%hru_id) + bmi_status = BMI_SUCCESS + case("hru_area") + size = sizeof(this%model%parameters%hru_area(1)) + bmi_status = BMI_SUCCESS + case("latitude") + size = sizeof(this%model%parameters%latitude(1)) + bmi_status = BMI_SUCCESS + case("elev") + size = sizeof(this%model%parameters%elev(1)) + bmi_status = BMI_SUCCESS + case("scf") + size = sizeof(this%model%parameters%scf(1)) + bmi_status = BMI_SUCCESS + case("mfmax") + size = sizeof(this%model%parameters%mfmax(1)) + bmi_status = BMI_SUCCESS + case("mfmin") + size = sizeof(this%model%parameters%mfmin(1)) + bmi_status = BMI_SUCCESS + case("uadj") + size = sizeof(this%model%parameters%uadj(1)) + bmi_status = BMI_SUCCESS + case("si") + size = sizeof(this%model%parameters%si(1)) + bmi_status = BMI_SUCCESS + case("pxtemp") + size = sizeof(this%model%parameters%pxtemp(1)) + bmi_status = BMI_SUCCESS + case("nmf") + size = sizeof(this%model%parameters%nmf(1)) + bmi_status = BMI_SUCCESS + case("tipm") + size = sizeof(this%model%parameters%tipm(1)) + bmi_status = BMI_SUCCESS + case("mbase") + size = sizeof(this%model%parameters%mbase(1)) + bmi_status = BMI_SUCCESS + case("plwhc") + size = sizeof(this%model%parameters%plwhc(1)) + bmi_status = BMI_SUCCESS + case("daygm") + size = sizeof(this%model%parameters%daygm(1)) + bmi_status = BMI_SUCCESS + case("total_area") + size = sizeof(this%model%parameters%total_area) + bmi_status = BMI_SUCCESS + case("adc1") + size = sizeof(this%model%parameters%adc(1,:)) + bmi_status = BMI_SUCCESS + case("adc2") + size = sizeof(this%model%parameters%adc(2,:)) + bmi_status = BMI_SUCCESS + case("adc3") + size = sizeof(this%model%parameters%adc(3,:)) + bmi_status = BMI_SUCCESS + case("adc4") + size = sizeof(this%model%parameters%adc(4,:)) + bmi_status = BMI_SUCCESS + case("adc5") + size = sizeof(this%model%parameters%adc(5,:)) + bmi_status = BMI_SUCCESS + case("adc6") + size = sizeof(this%model%parameters%adc(6,:)) + bmi_status = BMI_SUCCESS + case("adc7") + size = sizeof(this%model%parameters%adc(7,:)) + bmi_status = BMI_SUCCESS + case("adc8") + size = sizeof(this%model%parameters%adc(8,:)) + bmi_status = BMI_SUCCESS + case("adc9") + size = sizeof(this%model%parameters%adc(9,:)) + bmi_status = BMI_SUCCESS + case("adc10") + size = sizeof(this%model%parameters%adc(10,:)) + bmi_status = BMI_SUCCESS + case("adc11") + size = sizeof(this%model%parameters%adc(11,:)) + bmi_status = BMI_SUCCESS case default size = -1 bmi_status = BMI_FAILURE + call write_log("snow17_var_itemsize - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_var_itemsize @@ -638,17 +794,35 @@ function snow17_var_nbytes(this, name, nbytes) result (bmi_status) integer, intent(out) :: nbytes integer :: bmi_status integer :: s1, s2, s3, grid, grid_size, item_size - - s1 = this%get_var_grid(name, grid) - s2 = this%get_grid_size(grid, grid_size) - s3 = this%get_var_itemsize(name, item_size) - - if ((s1 == BMI_SUCCESS).and.(s2 == BMI_SUCCESS).and.(s3 == BMI_SUCCESS)) then - nbytes = item_size * grid_size - bmi_status = BMI_SUCCESS + + if (name == "serialization_create" .or. name == "serialization_size") then + nbytes = storage_size(0_int64)/8 !returns size in bits. So, divide by 8 for bytes. + bmi_status = BMI_SUCCESS + else if (name == "serialization_state") then + if(.not.allocated(this%model%serialization_buffer) .or. size(this%model%serialization_buffer) == 0) then + nbytes = -1 + call write_log("Serialization not set yet!", LOG_LEVEL_WARNING) + bmi_status = BMI_FAILURE + else + nbytes = size(this%model%serialization_buffer,KIND=int64) + bmi_status = BMI_SUCCESS + end if + else if (name == "serialization_free") then + nbytes = storage_size(0_int32)/8 !returns size in bits. So, divide by 8 for bytes. + bmi_status = BMI_SUCCESS else - nbytes = -1 - bmi_status = BMI_FAILURE + s1 = this%get_var_grid(name, grid) + s2 = this%get_grid_size(grid, grid_size) + s3 = this%get_var_itemsize(name, item_size) + + if ((s1 == BMI_SUCCESS).and.(s2 == BMI_SUCCESS).and.(s3 == BMI_SUCCESS)) then + nbytes = item_size * grid_size + bmi_status = BMI_SUCCESS + else + nbytes = -1 + bmi_status = BMI_FAILURE + call write_log("snow17_var_nbytes - " // name // " not found.", LOG_LEVEL_SEVERE) + end if end if end function snow17_var_nbytes @@ -678,9 +852,18 @@ function snow17_get_int(this, name, dest) result (bmi_status) ! case("model__identification_number") ! dest = [this%model%id] ! bmi_status = BMI_SUCCESS + case("serialization_size") + if(.not.allocated(this%model%serialization_buffer) .or. size(this%model%serialization_buffer) == 0) then + call write_log("Serialization not set yet!", LOG_LEVEL_WARNING) + bmi_status = BMI_FAILURE + else + dest = size(this%model%serialization_buffer,KIND=int64) + bmi_status = BMI_SUCCESS + end if case default dest(:) = -1 bmi_status = BMI_FAILURE + call write_log("snow17_get_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_int @@ -690,6 +873,7 @@ function snow17_get_float(this, name, dest) result (bmi_status) character (len=*), intent(in) :: name real, intent(inout) :: dest(:) integer :: bmi_status + character(len=256) :: msg ! for logging messages select case(name) case("precip") @@ -709,10 +893,110 @@ function snow17_get_float(this, name, dest) result (bmi_status) bmi_status = BMI_SUCCESS case("raim") dest(1) = this%model%modelvar%raim_comb + + ! handle very small negative raim values that can occur due to round-off error or floating-point artifacts + if (dest(1) < 0.0 .and. dest(1) > -1.0e-6) then + dest(1) = 0.0 + write(msg, '(A,ES12.5,A)') "snow17_get_float - 'raim' is negligibly negative (", & + this%model%modelvar%raim_comb, " mm/s), set to 0.0" + call write_log(msg, LOG_LEVEL_INFO) + bmi_status = BMI_SUCCESS + + ! Throw an error if it’s truly negative + else if (this%model%modelvar%raim(1) <= -1.0e-6) then + write(msg,'(A,ES12.5,A)') "snow17_get_float - 'raim' is invalid (", this%model%modelvar%raim(1), \ + " mm/s), must be non-negative." + call write_log(msg, LOG_LEVEL_SEVERE) + bmi_status = BMI_FAILURE + else + bmi_status = BMI_SUCCESS + end if + + !case("hru_id") + ! dest = [this%model%parameters%hru_id] + ! bmi_status = BMI_SUCCESS + case("hru_area") + dest = [this%model%parameters%hru_area] + bmi_status = BMI_SUCCESS + case("latitude") + dest = [this%model%parameters%latitude] + bmi_status = BMI_SUCCESS + case("elev") + dest = [this%model%parameters%elev] + bmi_status = BMI_SUCCESS + case("scf") + dest = [this%model%parameters%scf] + bmi_status = BMI_SUCCESS + case("mfmax") + dest = [this%model%parameters%mfmax] + bmi_status = BMI_SUCCESS + case("mfmin") + dest = [this%model%parameters%mfmin] + bmi_status = BMI_SUCCESS + case("uadj") + dest = [this%model%parameters%uadj] + bmi_status = BMI_SUCCESS + case("si") + dest = [this%model%parameters%si] + bmi_status = BMI_SUCCESS + case("pxtemp") + dest = [this%model%parameters%pxtemp] + bmi_status = BMI_SUCCESS + case("nmf") + dest = [this%model%parameters%nmf] + bmi_status = BMI_SUCCESS + case("tipm") + dest = [this%model%parameters%tipm] + bmi_status = BMI_SUCCESS + case("mbase") + dest = [this%model%parameters%mbase] + bmi_status = BMI_SUCCESS + case("plwhc") + dest = [this%model%parameters%plwhc] + bmi_status = BMI_SUCCESS + case("daygm") + dest = [this%model%parameters%daygm] + bmi_status = BMI_SUCCESS + case("adc") + dest = [this%model%parameters%adc] + bmi_status = BMI_SUCCESS + !case("adc2") + ! dest = [this%model%parameters%adc2] + ! bmi_status = BMI_SUCCESS + !case("adc3") + ! dest = [this%model%parameters%adc3] + ! bmi_status = BMI_SUCCESS + !case("adc4") + ! dest = [this%model%parameters%adc4] + ! bmi_status = BMI_SUCCESS + !case("adc5") + ! dest = [this%model%parameters%adc5] + ! bmi_status = BMI_SUCCESS + !case("adc6") + ! dest = [this%model%parameters%adc6] + ! bmi_status = BMI_SUCCESS + !case("adc7") + ! dest = [this%model%parameters%adc7] + ! bmi_status = BMI_SUCCESS + !case("adc8") + ! dest = [this%model%parameters%adc8] + ! bmi_status = BMI_SUCCESS + !case("adc9") + ! dest = [this%model%parameters%adc9] + ! bmi_status = BMI_SUCCESS + !case("adc10") + ! dest = [this%model%parameters%adc10] + ! bmi_status = BMI_SUCCESS + !case("adc11") + ! dest = [this%model%parameters%adc11] + ! bmi_status = BMI_SUCCESS + case("total_area") + dest(1) = this%model%parameters%total_area bmi_status = BMI_SUCCESS case default dest(:) = -1.0 bmi_status = BMI_FAILURE + call write_log("snow17_get_float - " // name // " not found.", LOG_LEVEL_SEVERE) end select ! NOTE, if vars are gridded, then use: ! dest = reshape(this%model%temperature, [this%model%n_x*this%model%n_y]) @@ -731,6 +1015,7 @@ function snow17_get_double(this, name, dest) result (bmi_status) case default dest(:) = -1.d0 bmi_status = BMI_FAILURE + call write_log("snow17_get_double - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_double @@ -748,8 +1033,12 @@ function snow17_get_ptr_int(this, name, dest_ptr) result (bmi_status) !==================== UPDATE IMPLEMENTATION IF NECESSARY FOR INTEGER VARS ================= select case(name) + case("serialization_state") + dest_ptr = this%model%serialization_buffer + bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE + call write_log("snow17_get_ptr_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_ptr_int @@ -765,6 +1054,7 @@ function snow17_get_ptr_float(this, name, dest_ptr) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_get_ptr_float - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_ptr_float @@ -782,6 +1072,7 @@ function snow17_get_ptr_double(this, name, dest_ptr) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_get_ptr_double - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_ptr_double @@ -800,6 +1091,7 @@ function snow17_get_at_indices_int(this, name, dest, inds) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_get_at_indices_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_at_indices_int @@ -818,6 +1110,7 @@ function snow17_get_at_indices_float(this, name, dest, inds) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_get_at_indices_float - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_at_indices_float @@ -836,6 +1129,7 @@ function snow17_get_at_indices_double(this, name, dest, inds) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_get_at_indices_double - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_get_at_indices_double @@ -845,6 +1139,7 @@ function snow17_set_int(this, name, src) result (bmi_status) character (len=*), intent(in) :: name integer, intent(in) :: src(:) integer :: bmi_status + integer(kind=int64) :: exec_status !==================== UPDATE IMPLEMENTATION IF NECESSARY FOR INTEGER VARS ================= @@ -852,8 +1147,32 @@ function snow17_set_int(this, name, src) result (bmi_status) ! case("model__identification_number") ! this%model%id = src(1) ! bmi_status = BMI_SUCCESS - case default + case("serialization_create") + call new_serialization_request(this%model, exec_status) + if (exec_status == 0) then + bmi_status = BMI_SUCCESS + call write_log("Serialization for state saving complete", LOG_LEVEL_DEBUG) + 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, exec_status) + if (exec_status == 0) then + bmi_status = BMI_SUCCESS + call write_log("Deserialization for state saving complete", LOG_LEVEL_DEBUG) + else + bmi_status = BMI_FAILURE + call write_log(" Failed to deserialize state saving data", LOG_LEVEL_FATAL) + end if + case("serialization_free") + if(allocated(this%model%serialization_buffer)) then + deallocate(this%model%serialization_buffer) + end if + bmi_status = BMI_SUCCESS + case default bmi_status = BMI_FAILURE + call write_log("snow17_set_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_set_int @@ -862,7 +1181,7 @@ function snow17_set_float(this, name, src) result (bmi_status) class (bmi_snow17), intent(inout) :: this character (len=*), intent(in) :: name real, intent(in) :: src(:) - integer :: bmi_status + integer :: bmi_status ! NOTE: if run in a vector (snowband mode), this code will need revising ! to set the basin average (ie, restart capability) @@ -886,8 +1205,90 @@ function snow17_set_float(this, name, src) result (bmi_status) case("raim") this%model%modelvar%raim(1) = src(1) bmi_status = BMI_SUCCESS + !case("hru_id") + ! this%model%parameters%hru_id = src(1) + ! bmi_status = BMI_SUCCESS + case("scf") + this%model%parameters%scf(:) = src(:) + bmi_status = BMI_SUCCESS + case("mfmax") + this%model%parameters%mfmax(:) = src(:) + bmi_status = BMI_SUCCESS + case("mfmin") + this%model%parameters%mfmin(:) = src(:) + bmi_status = BMI_SUCCESS + case("uadj") + this%model%parameters%uadj(:) = src(:) + bmi_status = BMI_SUCCESS + case("si") + this%model%parameters%si(:) = src(:) + bmi_status = BMI_SUCCESS + case("pxtemp") + this%model%parameters%pxtemp(:) = src(:) + bmi_status = BMI_SUCCESS + case("nmf") + this%model%parameters%nmf(:) = src(:) + bmi_status = BMI_SUCCESS + case("tipm") + this%model%parameters%tipm(:) = src(:) + bmi_status = BMI_SUCCESS + case("mbase") + this%model%parameters%mbase(:) = src(:) + bmi_status = BMI_SUCCESS + case("plwhc") + this%model%parameters%plwhc(:) = src(:) + bmi_status = BMI_SUCCESS + case("daygm") + this%model%parameters%daygm(:) = src(:) + bmi_status = BMI_SUCCESS + case("adc1") + this%model%parameters%adc(1,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc2") + this%model%parameters%adc(2,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc3") + this%model%parameters%adc(3,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc4") + this%model%parameters%adc(4,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc5") + this%model%parameters%adc(5,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc6") + this%model%parameters%adc(6,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc7") + this%model%parameters%adc(7,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc8") + this%model%parameters%adc(8,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc9") + this%model%parameters%adc(9,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc10") + this%model%parameters%adc(10,:) = src(:) + bmi_status = BMI_SUCCESS + case("adc11") + this%model%parameters%adc(11,:) = src(:) + bmi_status = BMI_SUCCESS + case("elev") + this%model%parameters%elev(:) = src(:) + bmi_status = BMI_SUCCESS + case("latitude") + this%model%parameters%latitude(:) = src(:) + bmi_status = BMI_SUCCESS + case("hru_area") + this%model%parameters%hru_area(:) = src(:) + bmi_status = BMI_SUCCESS + case("total_area") + this%model%parameters%total_area = src(1) + bmi_status = BMI_SUCCESS case default bmi_status = BMI_FAILURE + call write_log("snow17_set_float - " // name // " not found.", LOG_LEVEL_SEVERE) end select ! NOTE, if vars are gridded, then use: ! this%model%temperature = reshape(src, [this%model%n_y, this%model%n_x]) @@ -905,6 +1306,7 @@ function snow17_set_double(this, name, src) result (bmi_status) select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_set_double - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_set_double @@ -923,6 +1325,7 @@ function snow17_set_at_indices_int(this, name, inds, src) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_set_indices_at_int - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_set_at_indices_int @@ -941,6 +1344,7 @@ function snow17_set_at_indices_float(this, name, inds, src) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_set_indices_at_float - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_set_at_indices_float @@ -959,6 +1363,7 @@ function snow17_set_at_indices_double(this, name, inds, src) & select case(name) case default bmi_status = BMI_FAILURE + call write_log("snow17_set_indices_at_double - " // name // " not found.", LOG_LEVEL_SEVERE) end select end function snow17_set_at_indices_double @@ -1004,6 +1409,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("register_bmi - Cant associate the wrapper pointer to the created model instance", LOG_LEVEL_SEVERE) else !Return the pointer to box this = c_loc(bmi_box) diff --git a/src/driver/driver_bmi.f90 b/src/driver/driver_bmi.f90 index 181a314..8c8ad86 100644 --- a/src/driver/driver_bmi.f90 +++ b/src/driver/driver_bmi.f90 @@ -17,6 +17,7 @@ program multi_driver use bmi_snow17_module use bmif_2_0 use dateTimeUtilsModule + use snow_log_module implicit none @@ -42,12 +43,12 @@ program multi_driver ! Initialize ! Call the initialize_from_file() subroutine in src/RunSnow17.f90 !--------------------------------------------------------------------- - print*, "Initializing run ..." + call write_log("driver - Initializing run ...", LOG_LEVEL_INFO) call get_command_argument(1, namelist_file, status=status) !if( .not. ( present(namelist_file) ) ) then if( status /= 0 ) then namelist_file = "namelist.input" - print*, 'No namelist filename supplied -- attempting to read default file called namelist.input' + call write_log('No namelist filename supplied -- attempting to read default file called namelist.input', LOG_LEVEL_INFO) endif status = m%initialize(namelist_file) @@ -62,9 +63,8 @@ program multi_driver ! create optional screen output for run times call unix_to_datehr(current_time, start_datehr) call unix_to_datehr(end_time, end_datehr) - print*,'----'; - print*, 'Running model => start: ', start_datehr, ' end: ', end_datehr, ' timesteps: ', int((end_time - current_time)/dt) - print*,'----' + call write_log('Running model => start: '// start_datehr // ' end: ' // end_datehr, LOG_LEVEL_INFO) + call write_log(' timesteps: ' // itoa(int((end_time - current_time)/dt)), LOG_LEVEL_INFO) ! loop through timesteps and update model while current time <= end time ( do while (current_time .le. end_time) @@ -76,8 +76,8 @@ program multi_driver ! Finalize the model run ! All model finalization code in ../src/RunSnow17.f90 !--------------------------------------------------------------------- - print*, "Finalizing..." + call write_log("Finalizing...", LOG_LEVEL_INFO) status = m%finalize() - print*, "DONE" + call write_log("DONE", LOG_LEVEL_INFO) end program multi_driver diff --git a/src/share/byte_utilities.f90 b/src/share/byte_utilities.f90 new file mode 100644 index 0000000..fb3e2e9 --- /dev/null +++ b/src/share/byte_utilities.f90 @@ -0,0 +1,328 @@ +module byte_utilities + use iso_fortran_env + use,intrinsic :: ieee_arithmetic + implicit none + public + contains + logical function detect_little_endian() + ! used by the library to detect host endianness + ! Note: DOES NOT HANDLE MIDDLE-ENDIAN + ! @returns .true. if little endian, .false. otherwise + detect_little_endian = (1 == transfer([1_int8, 0_int8], 0_int16) ) + end function + + subroutine print_endianness() + ! debugging function to print out whether the library + ! thinks the host system is little or big endian + if (detect_little_endian()) then + print *, "Detected System Endianness: Little" + else + print *, "Detected System Endiannes: Big" + end if + end subroutine + + ! BIG ENDIAN bytes ==> LITTLE ENDIAN + integer(kind=int16) function bytes_be_int_le_2(bytes) + ! converts bytes in big-endian to an int16 in little endian + byte, dimension(2), intent(in) :: bytes + bytes_be_int_le_2 = transfer([bytes(2), bytes(1)], 0_int16) + end function + + integer(kind=int32) function bytes_be_int_le_4(bytes) + ! converts bytes in big-endian to an int32 in little endian + byte, dimension(4), intent(in) :: bytes + bytes_be_int_le_4 = transfer([bytes(4), bytes(3), bytes(2), bytes(1)], 0_int32) + end function + + integer(kind=int64) function bytes_be_int_le_8(bytes) + ! converts bytes in big-endian to an int64 in little endian + byte, dimension(8), intent(in) :: bytes + bytes_be_int_le_8 = transfer([bytes(8), bytes(7), bytes(6), bytes(5), & + bytes(4), bytes(3), bytes(2), bytes(1)], 0_int64) + end function + + real(kind=real32) function bytes_be_real_le_4(bytes) + ! converts bytes in big-endian to a real32 in little endian + byte, dimension(4), intent(in) :: bytes + bytes_be_real_le_4 = transfer([bytes(4), bytes(3), bytes(2), bytes(1)], 1.0_real32) + end function + + real(kind=real64) function bytes_be_real_le_8(bytes) + ! converts bytes in big-endian to a real64 in little endian + byte, dimension(8), intent(in) :: bytes + bytes_be_real_le_8 = transfer([bytes(8), bytes(7), bytes(6), bytes(5), & + bytes(4), bytes(3), bytes(2), bytes(1)], 1.0_real64) + end function + + ! BIG ENDIAN bytes ==> BIG ENDIAN + integer(kind=int16) function bytes_be_int_be_2(bytes) + ! converts bytes in big-endian to an int16 in big endian + byte, dimension(2), intent(in) :: bytes + bytes_be_int_be_2 = transfer([bytes(1), bytes(2)], 0_int16) + end function + + integer(kind=int32) function bytes_be_int_be_4(bytes) + ! converts bytes in big-endian to an int32 in big endian + byte, dimension(4), intent(in) :: bytes + bytes_be_int_be_4 = transfer([bytes(1), bytes(2), bytes(3), bytes(4)], 0_int32) + end function + + integer(kind=int64) function bytes_be_int_be_8(bytes) + ! converts bytes in big-endian to an int64 in big endian + byte, dimension(8), intent(in) :: bytes + bytes_be_int_be_8 = transfer([bytes(1), bytes(2), bytes(3), bytes(4), & + bytes(5), bytes(6), bytes(7), bytes(8)], 0_int64) + end function + + real(kind=real32) function bytes_be_real_be_4(bytes) + ! converts bytes in big-endian to a real32 in big endian + byte, dimension(4), intent(in) :: bytes + bytes_be_real_be_4 = transfer([bytes(1), bytes(2), bytes(3), bytes(4)], 1.0_real32) + end function + + real(kind=real64) function bytes_be_real_be_8(bytes) + ! converts bytes in big-endian to a real32 in big endian + byte, dimension(8), intent(in) :: bytes + bytes_be_real_be_8 = transfer([bytes(1), bytes(2), bytes(3), bytes(4), & + bytes(5), bytes(6), bytes(7), bytes(8)], 1.0_real64) + end function + + integer(kind=int16) function bytes_be_to_int_2(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(2), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_2 = bytes_be_int_le_2(bytes) + else + bytes_be_to_int_2 = bytes_be_int_be_2(bytes) + end if + end function + + integer(kind=int32) function bytes_be_to_int_4(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_4 = bytes_be_int_le_4(bytes) + else + bytes_be_to_int_4 = bytes_be_int_be_4(bytes) + end if + end function + + integer(kind=int64) function bytes_be_to_int_8(bytes, e) + ! converts bytes in big-endian to an int16 based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_int_8 = bytes_be_int_le_8(bytes) + else + bytes_be_to_int_8 = bytes_be_int_be_8(bytes) + end if + end function + + real(kind=real32) function bytes_be_to_real_4(bytes, e) + ! converts bytes in big-endian to a real32 based on requested endianness + ! @param[in] e - .true. for little endian, .false for big endian + byte, dimension(4), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_real_4 = bytes_be_real_le_4(bytes) + else + bytes_be_to_real_4 = bytes_be_real_be_4(bytes) + end if + end function + + real(kind=real64) function bytes_be_to_real_8(bytes, e) + ! converts bytes in big-endian to a real64 based on requested endianness + ! @param[in] e - .true. for little endian, .false for big endian + byte, dimension(8), intent(in) :: bytes + logical, intent(in) :: e + if (e) then + bytes_be_to_real_8 = bytes_be_real_le_8(bytes) + else + bytes_be_to_real_8 = bytes_be_real_be_8(bytes) + end if + end function + + ! LITTLE ENDIAN ==> BIG ENDIAN bytes + subroutine int_le_to_bytes_be_2(bytes, value) + ! converts int16 little endian to bytes in big-endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + bytes(1) = int(ibits(value, 8, 8), kind=int8) + bytes(2) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine int_le_to_bytes_be_4(bytes, value) + ! converts int32 little endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + bytes(1) = int(ibits(value, 24, 8), kind=int8) + bytes(2) = int(ibits(value, 16, 8), kind=int8) + bytes(3) = int(ibits(value, 8, 8), kind=int8) + bytes(4) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine int_le_to_bytes_be_8(bytes, value) + ! converts int64 little endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + bytes(1) = int(ibits(value, 56, 8), kind=int8) + bytes(2) = int(ibits(value, 48, 8), kind=int8) + bytes(3) = int(ibits(value, 40, 8), kind=int8) + bytes(4) = int(ibits(value, 32, 8), kind=int8) + bytes(5) = int(ibits(value, 24, 8), kind=int8) + bytes(6) = int(ibits(value, 16, 8), kind=int8) + bytes(7) = int(ibits(value, 8, 8), kind=int8) + bytes(8) = int(ibits(value, 0, 8), kind=int8) + end subroutine + + subroutine real_le_to_bytes_be_4(bytes, value) + ! convert real32 little endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + bytes(4:1:-1) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_le_to_bytes_be_8(bytes, value) + ! convert real64 little endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + bytes(8:1:-1) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + ! BIG ENDIAN ==> BIG ENDIAN bytes + subroutine int_be_to_bytes_be_2(bytes, value) + ! converts int16 big endian to bytes in big-endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + bytes(1:2) = transfer(value, [0_int8, 0_int8]) + end subroutine + + subroutine int_be_to_bytes_be_4(bytes, value) + ! converts int32 big endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + bytes(1:4) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine int_be_to_bytes_be_8(bytes, value) + ! converts int64 big endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + bytes(1:8) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_be_to_bytes_be_4(bytes, value) + ! converts real32 big endian to bytes in big-endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + bytes(1:4) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine real_be_to_bytes_be_8(bytes, value) + ! converts real64 big endian to bytes in big-endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + bytes(1:8) = transfer(value, [0_int8, 0_int8, 0_int8, 0_int8, & + 0_int8, 0_int8, 0_int8, 0_int8]) + end subroutine + + subroutine int_to_bytes_be_2(bytes, value) + ! converts int16 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(2), intent(inout) :: bytes + integer(kind=int16), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_2(bytes, value) + else + call int_be_to_bytes_be_2(bytes, value) + end if + end subroutine + + subroutine int_to_bytes_be_4(bytes, value) + ! converts int32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(inout) :: bytes + integer(kind=int32), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_4(bytes, value) + else + call int_be_to_bytes_be_4(bytes, value) + end if + end subroutine + + subroutine int_to_bytes_be_8(bytes, value) + ! converts int64 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(inout) :: bytes + integer(kind=int64), intent(in) :: value + if (detect_little_endian()) then + call int_le_to_bytes_be_8(bytes, value) + else + call int_be_to_bytes_be_8(bytes, value) + end if + end subroutine + + subroutine real_to_bytes_be_4(bytes, value) + ! converts real32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(4), intent(inout) :: bytes + real(kind=real32), intent(in) :: value + if (detect_little_endian()) then + call real_le_to_bytes_be_4(bytes, value) + else + call real_be_to_bytes_be_4(bytes, value) + end if + end subroutine + + subroutine real_to_bytes_be_8(bytes, value) + ! converts real32 to bytes in big-endian based on requested endianness + ! @param[in] e - .true. for little endian, .false. for big endian + byte, dimension(8), intent(inout) :: bytes + real(kind=real64), intent(in) :: value + if (detect_little_endian()) then + call real_le_to_bytes_be_8(bytes, value) + else + call real_be_to_bytes_be_8(bytes, value) + end if + end subroutine + + integer(kind=int16) function int8_as_unsigned(value) + ! interprets an unsigned int8 value as a signed value + ! by increasing the storage width + integer(kind=int8), intent(in) :: value + + int8_as_unsigned = value + if (value < 0) then + int8_as_unsigned = iand(int8_as_unsigned, 255_int16) + end if + end function + + integer(kind=int32) function int16_as_unsigned(value) + ! interprets an unsigned int16 value as a signed value + ! by increasing the storage width + integer(kind=int16), intent(in) :: value + + int16_as_unsigned = value + if (value < 0) then + int16_as_unsigned = iand(int16_as_unsigned, 65535_int32) + end if + end function + + integer(kind=int64) function int32_as_unsigned(value) + ! interprets an unsigned int32 value as a signed value + ! by increasing the storage width + integer(kind=int32), intent(in) :: value + + int32_as_unsigned = value + if (value < 0) then + int32_as_unsigned = iand(int32_as_unsigned, 4294967295_int64) + end if + end function +end module diff --git a/src/share/dateTimeUtilsModule.f90 b/src/share/dateTimeUtilsModule.f90 index add68d6..d4a3133 100644 --- a/src/share/dateTimeUtilsModule.f90 +++ b/src/share/dateTimeUtilsModule.f90 @@ -2,6 +2,7 @@ ! copied from the GMET code at https://github.com/NCAR/GMET/ module dateTimeUtilsModule + use snow_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)) @@ -887,8 +888,9 @@ double precision function date_to_unix (date) 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:'//date//', ' & + //itoa(year)//', '//itoa(month)//', '//itoa(day)//', '//itoa(hour)//', '//itoa(min)//', ' & + //itoa(sec)//', '//itoa(error), LOG_LEVEL_FATAL) stop !return end if @@ -1005,11 +1007,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/share/ioModule.f90 b/src/share/ioModule.f90 index d62250a..61ec208 100644 --- a/src/share/ioModule.f90 +++ b/src/share/ioModule.f90 @@ -1,13 +1,15 @@ module ioModule - + use snow_log_module use dateTimeUtilsModule use parametersType use runInfoType use forcingType use modelVarType - + implicit none - + + character(len=128) :: log_msg + contains subroutine read_snow17_parameters(this, param_file_name, runinfo) @@ -32,12 +34,17 @@ subroutine read_snow17_parameters(this, param_file_name, runinfo) ios = 0 ! open parameter file - open(unit=51,file=trim(param_file_name),status='old') - - print*, 'Reading Snow17 parameters' + open(unit=51,file=trim(param_file_name),status='old', IOSTAT=ios) + if (ios /= 0) then + call write_log('Error opening file: ' // param_file_name, LOG_LEVEL_FATAL) + stop + endif + + call write_log("Reading Snow17 parameters", LOG_LEVEL_INFO) ! --- now loop through parameter file and assign parameters n_params_read = 0 + ios = 0 do while(ios .eq. 0) read(unit=51,FMT='(A)',IOSTAT=ios) readline @@ -134,7 +141,7 @@ subroutine read_snow17_parameters(this, param_file_name, runinfo) read(readline, *, iostat=ios) this%adc(11,:) n_params_read = n_params_read + 1 case default - print *, 'Parameter ',param,' not recognized in snow file' + call write_log('Parameter ' // param // ' not recognized in snow file', LOG_LEVEL_SEVERE) end select end if @@ -144,7 +151,7 @@ subroutine read_snow17_parameters(this, param_file_name, runinfo) ! quick check on completeness if(n_params_read /= 26) then - print *, 'Read ', n_params_read , ' SNOW17 params, but need 26. Quitting.'; stop + call write_log("Read " // itoa(n_params_read) // " SNOW17 params, but need 26. Quitting.", LOG_LEVEL_FATAL) end if ! calculate derived parameters @@ -174,7 +181,8 @@ SUBROUTINE init_forcing_files(namelist, runinfo, parameters) real :: pcp, tav ! --- code ------------------------------------------------------------------ - print*, 'Initializing forcing files' + call write_log("Initializing forcing files", LOG_LEVEL_INFO) + ios = 0 found_start = 0 do nh=1, runinfo%n_hrus @@ -185,6 +193,8 @@ SUBROUTINE init_forcing_files(namelist, runinfo, parameters) ! Check if the specified file exists inquire(file = trim(filename), exist = lexist) if (.not. lexist) then + call write_log('Problem !! File ' // trim(filename) // 'does not exists. Quitting.', LOG_LEVEL_FATAL) + call write_log('Check the forcing file specified as a command-line argument.', LOG_LEVEL_FATAL) write(*,'(/," ***** Problem *****")') write(*,'(" ***** File ''", A, "'' does not exist.")') trim(filename) write(*,'(" ***** Check the forcing file specified as a command-line argument",/)') @@ -194,6 +204,7 @@ SUBROUTINE init_forcing_files(namelist, runinfo, parameters) ! Open the forcing file open(runinfo%forcing_fileunits(nh), file = trim(filename), form = 'formatted', action = 'read', iostat = ierr) if (ierr /= 0) then + call write_log("Problem opening file " //trim(filename) //" Error Exiting", LOG_LEVEL_FATAL) write(*,'("Problem opening file ''", A, "''")') trim(filename) stop ": ERROR EXIT" endif @@ -216,7 +227,7 @@ SUBROUTINE init_forcing_files(namelist, runinfo, parameters) end do if(nh .eq. 1) then - print*, ' -- skipped ', skipcount ,' initial records in forcing files' + call write_log('Skipped ' // itoa(skipcount) // ' inaitial records in forcing files', LOG_LEVEL_INFO) endif ! backspace the file to the previous record @@ -226,7 +237,8 @@ SUBROUTINE init_forcing_files(namelist, runinfo, parameters) ! error out if start of any forcing file is not found if (found_start /= runinfo%n_hrus) then - print*, 'ERROR: found the starting date in only', found_start, ' out of', runinfo%n_hrus, ' forcing files. Quitting.'; stop + call write_log('Found the starting date in only' // itoa(found_start )// ' out of' // itoa( runinfo%n_hrus) // 'forcing files. Quitting', LOG_LEVEL_FATAL) + stop endif END SUBROUTINE init_forcing_files @@ -275,7 +287,8 @@ subroutine read_areal_forcing(namelist, parameters, runinfo, forcing) ! read one record from already open files and check success read (UNIT=runinfo%forcing_fileunits(nh), FMT=*, IOSTAT=ierr) yr, mnth, dy, hr, forcing%precip(nh), forcing%tair(nh) if(ierr /= 0) then - print*, 'ERROR: failed to read forcing from file', trim(namelist%forcing_root) // trim(parameters%hru_id(nh)) + log_msg = 'Failed to read forcing from file ' // trim(namelist%forcing_root) // trim(parameters%hru_id(nh)) + call write_log(log_msg // ' STOPPING', LOG_LEVEL_FATAL) STOP end if @@ -284,7 +297,8 @@ subroutine read_areal_forcing(namelist, parameters, runinfo, forcing) !print*, 'Read forcing datehr ', forcing_datehr if(forcing_datehr /= runinfo%curr_datehr) then - print*, 'ERROR: forcing datehr: ',forcing_datehr, ' does not match curr_datehr of run :', runinfo%curr_datehr + log_msg = 'Forcing datehr: ' // forcing_datehr // ' does not match curr_datehr of run :' // runinfo%curr_datehr + call write_log(log_msg // " STOPING", LOG_LEVEL_FATAL) STOP end if @@ -308,12 +322,13 @@ SUBROUTINE init_output_files(namelist, runinfo, parameters) ! --- code ------------------------------------------------------------------ - print*, 'Initializing output files' + call write_log("Initializing output files", LOG_LEVEL_INFO) ! Open the main basin-average output file and write header filename = trim(namelist%output_root) // trim(namelist%main_id) // '.txt' open(runinfo%output_fileunits(1), file = trim(filename), form = 'formatted', action = 'write', status='replace', iostat = ierr) if (ierr /= 0) then + call write_log("Problem opening file " // trim(filename) //". EXITING", LOG_LEVEL_FATAL) write(*,'("Problem opening file ''", A, "''")') trim(filename) stop ": ERROR EXIT" endif @@ -330,6 +345,7 @@ SUBROUTINE init_output_files(namelist, runinfo, parameters) ! Open the output files open(runinfo%output_fileunits(nh+1), file = trim(filename), form = 'formatted', action = 'write', status='replace', iostat = ierr) if (ierr /= 0) then + call write_log("Problem opening file " // trim(filename) //". EXITING", LOG_LEVEL_SEVERE) write(*,'("Problem opening file ''", A, "''")') trim(filename) stop ": ERROR EXIT" endif @@ -358,8 +374,7 @@ SUBROUTINE init_new_state_files(namelist, runinfo, parameters) ! --- code ------------------------------------------------------------------ - print*, 'Initializing new restart files' - + call write_log('Initializing new restart files', LOG_LEVEL_INFO) ! if user setting is to write out state files, open one for each snowband and write header row if (namelist%write_states == 1) then @@ -371,6 +386,7 @@ SUBROUTINE init_new_state_files(namelist, runinfo, parameters) ! Open the output files open(runinfo%state_fileunits(nh), file = trim(filename), form = 'formatted', action = 'write', status='replace', iostat = ierr) if (ierr /= 0) then + call write_log("Problem opening file " // trim(filename) //". EXITING", LOG_LEVEL_FATAL) write(*,'("Problem opening file ''", A, "''")') trim(filename) stop ": ERROR EXIT" endif @@ -400,7 +416,8 @@ subroutine write_snow17_statefile(runinfo, namelist, modelvar, n_curr_hru) write(runinfo%state_fileunits(n_curr_hru), 41, iostat=ierr) runinfo%curr_yr, runinfo%curr_mo, runinfo%curr_dy, runinfo%curr_hr, & modelvar%tprev(n_curr_hru), modelvar%cs(:,n_curr_hru) if(ierr /= 0) then - print*, 'ERROR writing state file information for sub-unit ', n_curr_hru; stop + call write_log("Error writing state file information for sub-unit " // itoa(n_curr_hru) // ". STOPPING", LOG_LEVEL_FATAL) + stop endif return @@ -431,14 +448,14 @@ subroutine read_snow17_statefiles (modelvar, namelist, parameters, runinfo) integer :: states_found ! counter to match hrus ! ---- code ----- - print*, 'Reading restart files' + call write_log('Reading restart files', LOG_LEVEL_INFO) ! starting statefiles match format of statefile outputs (date then variables) ! statefile read looks for matching date timestep before run start because states are written at end of timestep prev_datetime = (runinfo%start_datetime - runinfo%dt) ! decrement unix model run time in seconds by DT call unix_to_datehr (dble(prev_datetime), state_datehr) ! create statefile datestring to match - print*, ' -- state datehr: ', state_datehr - + call write_log(" -- state datehr: " // trim(state_datehr), LOG_LEVEL_INFO) + ! loop over hrus and read and store initial state values states_found = 0 ! set counter do hru=1, runinfo%n_hrus @@ -446,12 +463,19 @@ subroutine read_snow17_statefiles (modelvar, namelist, parameters, runinfo) ! make state filename state_filename = trim(namelist%snow_state_in_root) // trim(parameters%hru_id(hru)) // '.txt' open(unit=95,FILE=trim(state_filename), FORM='formatted', status='old') + open(unit=95,FILE=trim(state_filename), FORM='formatted', status='old', IOSTAT=ios) + if (ios /= 0) then + write(*,'("Problem opening file ''", A, "''")') trim(state_filename) + call write_log("Problem opening file " //trim(state_filename), LOG_LEVEL_SEVERE) + endif + !print*, ' -- reading snow state file: ', trim(state_filename) ! format for input is an unknown number of rows with 20 data columns (1 tprev, 19 for cs) ! the first column is the datestring; neg ios means end of file; pos means something wrong ! skip header row + ios = 0 read(95, *, IOSTAT=ios) ! read each row and check to see if the date matches the initial state date @@ -472,9 +496,9 @@ subroutine read_snow17_statefiles (modelvar, namelist, parameters, runinfo) ! check to make sure enough states on correct dates were found if (states_found /= runinfo%n_hrus) then - print*, 'ERROR: matching state not found in snow17 restart file. Looking for state date: ', state_datehr - print*, ' -- last state read was on: ', statefile_datehr - print*, 'Stopping. Check inputs!'; stop + call write_log("Matching state not found in sac restart file. Looking for state date: " // trim(state_datehr), LOG_LEVEL_FATAL) + call write_log("last state read was on: " // trim(statefile_datehr) // ". STOPPING. CHECK INPUTS!", LOG_LEVEL_FATAL) + stop endif return @@ -514,7 +538,8 @@ SUBROUTINE write_snow17_output(namelist, runinfo, parameters, forcing, modelvar, forcing%precip_scf(n_curr_hru)*runinfo%dt, & modelvar%sneqv(n_curr_hru)*1000., modelvar%snowh(n_curr_hru), modelvar%raim(n_curr_hru)*runinfo%dt if(ierr /= 0) then - print*, 'ERROR writing output information for sub-unit ', n_curr_hru; stop + call write_log('ERROR writing output information for sub-unit ' // itoa(n_curr_hru) // '. STOPPING.', LOG_LEVEL_FATAL) + stop endif end if ! IF case for writing HRU-specific output to file (not including states) @@ -527,7 +552,8 @@ SUBROUTINE write_snow17_output(namelist, runinfo, parameters, forcing, modelvar, forcing%tair_comb, forcing%precip_comb*runinfo%dt, forcing%precip_scf_comb*runinfo%dt, & modelvar%sneqv_comb*1000.0, modelvar%snowh_comb, modelvar%raim_comb*runinfo%dt if(ierr /= 0) then - print*, 'ERROR writing output information for basin average'; stop + call write_log("ERROR writing output information for basin average. STOPPING.", LOG_LEVEL_FATAL) + stop endif endif diff --git a/src/share/messagepack.f90 b/src/share/messagepack.f90 new file mode 100644 index 0000000..1d4c2a5 --- /dev/null +++ b/src/share/messagepack.f90 @@ -0,0 +1,107 @@ +module messagepack + + ! implement buffer or c++ vector + ! implement static buffer? + ! implement packing + ! implement unpacking + ! implement file io + use iso_fortran_env + use messagepack_value + use messagepack_user + use byte_utilities + + implicit none +contains + + subroutine print_bytes_as_hex(bytes, addhexmark) + ! prints a buffer of bytes as the unsigned hex version + ! @param[in] bytes - byte buffer to print + ! @param[in] addhexmark - If true, print with 0x prepended + ! @returns none + byte, dimension(:), allocatable, intent(in) :: bytes + logical, intent(in) :: addhexmark + + integer :: i + integer :: val + write(*, "(A2)", advance="no") "[ " + if (addhexmark) then + do i = 1,size(bytes) + val = int8_as_unsigned(bytes(i)) + write(*, '("0x", Z2.2, " ")', advance="no") val + end do + else + do i = 1,size(bytes) + val = int8_as_unsigned(bytes(i)) + write(*, '(Z2.2, " ")', advance="no") val + end do + end if + write(*,*) "]" + end subroutine + + subroutine unpack_array_int_1d(obj, om, errored) + ! Attempts to unpack a 1d messagepack array of integers + ! Note: does not check `is_unsigned`. + ! @param[in] obj - messagepack object + ! @param[out] om - dynamically allocated matrix + ! @param[out] errored - .true. if an error occurred + class(mp_value_type), allocatable, intent(in) :: obj + integer(kind=int64), dimension(:), allocatable, intent(out) :: om + logical, intent(out) :: errored + + ! variables + logical :: stat + integer(kind=int64) :: i, val, l + class(mp_arr_type), allocatable :: arr + + errored = .true. + call get_arr_ref(obj, arr, stat) + if (.not.(stat)) then + return + end if + ! initialize output + l = arr%numelements() + allocate(om(l)) + do i = 1,l + call get_int(arr%values(i)%obj, val, stat) + if (.not.(stat)) then + return + end if + om(i) = val + end do + errored = .false. + end subroutine + + subroutine unpack_array_real_1d(obj, om, errored) + ! Attempts to unpack a 1d messagepack array of reals + ! @param[in] obj - messagepack object + ! @param[out] om - dynamically allocated matrix + ! @param[out] errored - .true. if an error occurred + class(mp_value_type), allocatable, intent(in) :: obj + real(kind=real64), dimension(:), allocatable, intent(out) :: om + logical, intent(out) :: errored + + ! variables + logical :: stat + integer(kind=int64) :: i, l + real(kind=real64) :: val + class(mp_arr_type), allocatable :: arr + + errored = .true. + call get_arr_ref(obj, arr, stat) + if (.not.(stat)) then + return + end if + ! initialize output + l = arr%numelements() + allocate(om(l)) + do i = 1,l + call get_real(arr%values(i)%obj, val, stat) + if (.not.(stat)) then + return + end if + om(i) = val + end do + errored = .false. + end subroutine + +end module diff --git a/src/share/messagepack_user.f90 b/src/share/messagepack_user.f90 new file mode 100644 index 0000000..fa2394a --- /dev/null +++ b/src/share/messagepack_user.f90 @@ -0,0 +1,1169 @@ +! defines a class that stores callbacks for handling +! user extensions +module messagepack_user + use iso_fortran_env + use, intrinsic :: ieee_arithmetic + use messagepack_value + use byte_utilities + + implicit none + + private + + public :: msgpack, unpack_func, unpack_callback + public :: mp_timestamp_type, is_timestamp, get_timestamp_ref, register_extension + + integer, parameter, public :: MP_TS_EXT = -1 + + abstract interface + subroutine unpack_func(buffer, byteadvance, is_little_endian, mpv, successful) + import int64, mp_value_type + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + end subroutine + end interface + + type :: unpack_callback + procedure(unpack_func), pointer, nopass :: cb => null() + end type + + ! top level class where user is expected to interact with + ! messagepack utilities + type :: msgpack + class(unpack_callback), allocatable, dimension(:) :: f1 + class(unpack_callback), allocatable, dimension(:) :: f2 + class(unpack_callback), allocatable, dimension(:) :: f4 + class(unpack_callback), allocatable, dimension(:) :: f8 + class(unpack_callback), allocatable, dimension(:) :: f16 + class(unpack_callback), allocatable, dimension(:) :: e8 + class(unpack_callback), allocatable, dimension(:) :: e16 + class(unpack_callback), allocatable, dimension(:) :: e32 + logical, dimension(256) :: f1_allocated + logical, dimension(256) :: f2_allocated + logical, dimension(256) :: f4_allocated + logical, dimension(256) :: f8_allocated + logical, dimension(256) :: f16_allocated + logical, dimension(256) :: e8_allocated + logical, dimension(256) :: e16_allocated + logical, dimension(256) :: e32_allocated + + logical :: is_little_endian + logical :: fail_flag + character(:), allocatable :: error_message + logical :: extra_bytes + contains + procedure :: register_extension + procedure :: register_extension_super + procedure :: print_value + procedure :: print_value_with_args + procedure :: print_version + procedure :: failed + procedure :: pack_alloc + procedure :: pack_prealloc + procedure :: unpack + procedure :: unpack_buf + procedure :: is_available + procedure :: unpack_value + procedure :: unpack_map + procedure :: unpack_ext + procedure :: unpack_array + procedure :: extra_bytes_is_error + procedure :: check_size + end type + interface msgpack + procedure :: new_mp + end interface + + ! #region messagepack defined extensions go here + type, extends(mp_value_type) :: mp_timestamp_type + integer(kind=int64) :: seconds + integer(kind=int64) :: nanoseconds ! this must be positive + contains + procedure :: getsize => get_size_timestamp + procedure :: pack => pack_timestamp + end type + interface mp_timestamp_type + procedure :: new_timestamp + end interface + ! #endregion + + contains + type(msgpack) function new_mp() + logical :: err + procedure(unpack_func), pointer :: p + integer :: i + allocate(new_mp%f1(256)) + allocate(new_mp%f2(256)) + allocate(new_mp%f4(256)) + allocate(new_mp%f8(256)) + allocate(new_mp%f16(256)) + allocate(new_mp%e8(256)) + allocate(new_mp%e16(256)) + allocate(new_mp%e32(256)) + do i = 1,256 + new_mp%f1_allocated = .false. + new_mp%f2_allocated = .false. + new_mp%f4_allocated = .false. + new_mp%f8_allocated = .false. + new_mp%f16_allocated = .false. + new_mp%e8_allocated = .false. + new_mp%e16_allocated = .false. + new_mp%e32_allocated = .false. + end do + + ! AFAIK there is no stdlib equivalent of C++20 std::endian + new_mp%is_little_endian = detect_little_endian() + new_mp%fail_flag = .false. + new_mp%error_message = '' + new_mp%extra_bytes = .true. + + ! add timestamp here + p => unpack_timestamp_32 + call new_mp%register_extension_super(MP_FE4, -1_int8, p, err) + p => unpack_timestamp_64 + call new_mp%register_extension_super(MP_FE8, -1_int8, p, err) + p => unpack_timestamp_96 + call new_mp%register_extension_super(MP_E8, -1_int8, p, err) + end function + + subroutine extra_bytes_is_error(this, val) + ! manipulate this flag + class(msgpack) :: this + logical, intent(in) :: val + this%extra_bytes = val + end subroutine + + subroutine print_version(this) + class(msgpack) :: this + print *, "0.3.1" + end subroutine + + logical function failed(this) + class(msgpack) :: this + failed = this%fail_flag + end function + + type(mp_timestamp_type) function new_timestamp(sec, ns) + integer(kind=int64) :: sec + integer(kind=int64) :: ns + new_timestamp%seconds = sec + new_timestamp%nanoseconds = abs(ns) + end function + + subroutine register_extension(this, ext, typeid, cb, error) + ! Registers callbacks for handling extensions + ! Only allows registering ids [0 127] + class(msgpack) :: this + integer, intent(in) :: ext + integer(kind=int8), intent(in) :: typeid + procedure(unpack_func), pointer, intent(in) :: cb + logical, intent(out) :: error + + if (typeid < 0) then + error = .true. + return + end if + call this%register_extension_super(ext, typeid, cb, error) + end subroutine + + subroutine register_extension_super(this, ext, typeid, cb, error) + ! Registers callbacks for handling extensions + ! allows ids [-128 127] + class(msgpack) :: this + integer, intent(in) :: ext + integer(kind=int8), intent(in) :: typeid + procedure(unpack_func), pointer, intent(in) :: cb + logical, intent(out) :: error + + integer :: arr_index + + arr_index = typeid + 129 ! [-128, 127] -> [1, 256] + + select case(ext) + case (MP_FE1) + this%f1(arr_index)%cb => cb + this%f1_allocated(arr_index) = .true. + case (MP_FE2) + this%f2(arr_index)%cb => cb + this%f2_allocated(arr_index) = .true. + case (MP_FE4) + this%f4(arr_index)%cb => cb + this%f4_allocated(arr_index) = .true. + case (MP_FE8) + this%f8(arr_index)%cb => cb + this%f8_allocated(arr_index) = .true. + case (MP_FE16) + this%f16(arr_index)%cb => cb + this%f16_allocated(arr_index) = .true. + case (MP_E8) + this%e8(arr_index)%cb => cb + this%e8_allocated(arr_index) = .true. + case (MP_E16) + this%e16(arr_index)%cb => cb + this%e16_allocated(arr_index) = .true. + case (MP_E32) + this%e32(arr_index)%cb => cb + this%e16_allocated(arr_index) = .true. + end select + + error = .false. + end subroutine + + ! PACKING + subroutine pack_alloc(this, mpv, buffer) + ! Packs a messagepack object into a dynamically + ! allocated buffer, returned to the user. The user + ! must handle deallocation. + ! @param[in] this - self + ! @param[in] mpv - messagepack value to pack + ! @param[out] buffer - will contain serialized data + class(msgpack) :: this + class(mp_value_type) :: mpv + byte, allocatable, dimension(:), intent(out) :: buffer + integer(kind=int64) :: dblen + integer(kind=int64) :: numused + + call mpv%getsize(dblen) ! get buffer size required + allocate(buffer(dblen)) ! allocate buffer + + call mpv%pack(buffer, numused, this%fail_flag) + if (.not.(this%fail_flag)) then + if (dblen /= numused) then + this%fail_flag = .true. + this%error_message = 'Internal Error: packing failed' + end if + end if + end subroutine + + subroutine pack_prealloc(this, mpv, bytes_used, buffer) + ! Packs a messagepack object into a pre-allocated buffer, + ! returned to the user. This function does not check beforehand + ! for the array being the correct size, and will return an error + ! if the buffer is too small. + class(msgpack) :: this + class(mp_value_type) :: mpv + integer(kind=int64), intent(out) :: bytes_used + byte, allocatable, dimension(:), intent(inout) :: buffer + + call mpv%pack(buffer, bytes_used, this%fail_flag) + end subroutine + + subroutine unpack(this, buffer, mpv) + ! Unpack a MsgPack value from a buffer. + ! - nominally contains a single value + ! @param[in] this - self + ! @param[in] buffer - serialized messagepack data + ! @param[out] mpv - Deserialized value + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + class(mp_value_type), allocatable, intent(out) :: mpv + + integer(kind=int64) :: numbytes + + call this%unpack_buf(buffer, mpv, numbytes) + if (numbytes < size(buffer) .and. this%extra_bytes) then + ! configurable error + this%fail_flag = .true. + write(this%error_message, '(i0) (A)') size(buffer) - numbytes, ' extra bytes unused' + else if (numbytes > size(buffer)) then + this%fail_flag = .true. ! bug within reporting byte mechanism + write(this%error_message, '(A) (i0)') "internal error. number of bytes exceeds buffer size by: ", & + numbytes - size(buffer) + end if + end subroutine + + subroutine unpack_buf(this, buffer, mpv, numbytes) + ! Unpack a single value from a buffer. Additionally returns + ! the number of bytes used, in case the buffer has multiple + ! MessagePack values within it or is a rolling buffer, etc. + ! @param[in] this - self + ! @param[in] buffer - serialized messagepack data + ! @param[out] mpv - Deserialized value + ! @param[out] numbytes - Number of bytes used in the buffer + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + class(mp_value_type), allocatable, intent(out) :: mpv + integer(kind=int64), intent(out) :: numbytes + + logical :: successful + + this%fail_flag = .false. + call this%unpack_value(buffer, numbytes, mpv, successful) + this%fail_flag = .not.(successful) + + if (numbytes > size(buffer)) then + this%fail_flag = .true. ! bug within reporting byte mechanism + write(this%error_message, '(A) (i0)') "internal error. number of bytes exceeds buffer size by: ", & + numbytes - size(buffer) + end if + end subroutine + + logical function is_available(this, buffer) + ! Returns true if the buffer contains at least 1 complete + ! messagepack value + ! @param[in] this - instance + ! @param[in] buffer - serialized data + ! @returns - .true. if a complete messagepack value exists + class(msgpack) :: this + byte, dimension(:) :: buffer + + logical :: error + integer(kind=int64) :: numbytes + + call this%check_size(buffer, .true., numbytes, error) + is_available = .not.(error) + end function + + subroutine print_value(this, obj) + ! Prints MessagePack object with default options + ! @param[in] this - instance + ! @param[in] obj - MessagePack object to print + class(msgpack) :: this + class(mp_value_type), intent(in) :: obj + call this%print_value_with_args(obj, 0, .false., -1) + end subroutine + + recursive subroutine print_value_with_args(this, obj, indentation, & + sameline, maxelems) + ! Prints MessagePack object with a variety of configurability + ! @param[in] this - instance + ! @param[in] obj - MessagePack object to print in a pretty fashion + ! @param[in] indentation - number of levels of indentation to print with + ! @param[in] sameline - if true, compacts the output + ! @param[in] maxelems - if non-negative, limits number of elements printed + ! @returns None + class(msgpack), intent(in) :: this + class(mp_value_type), intent(in) :: obj + integer, intent(in) :: indentation + logical, intent(in) :: sameline + integer, intent(in) :: maxelems + integer(kind=int64) :: i, j, ind + + if (.not. sameline) then + do i = 1,indentation + write(*, "(A2)", advance="no") " " + end do + end if + + select type(obj) + class is (mp_nil_type) + write(*, "(A)", advance="no") "nil" + class is (mp_bool_type) + if (obj%value) then + write(*, "(A)", advance="no") "true" + else + write(*, "(A)", advance="no") "false" + end if + class is (mp_int_type) + if (obj%unsigned_64) then + write(*, "(I0, A)", advance="no") obj%value, "[OUT-OF-RANGE]" + else + write(*, "(I0)", advance="no") obj%value + end if + + class is (mp_float_type) + if (obj%is_64) then + write(*, "(F0.0)", advance="no") obj%f64value + else + write(*, "(F0.0)", advance="no") obj%f32value + end if + class is (mp_str_type) + write(*, "(A, A, A)", advance="no") char(34), obj%value, char(34) + class is (mp_arr_type) + write(*, "(A)", advance="no") "[" + printarr : do j = 1,obj%numelements() + call this%print_value_with_args(obj%values(j)%obj, 0, .true., maxelems) + write(*, "(A)", advance="no") ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A3)") "..." + exit printarr + end if + end do printarr + write(*, "(A)", advance="no") "]" + class is (mp_map_type) + write(*, "(A)") "{" + printmap : do j = 1, obj%numelements() + do i = 1,indentation+1 + write(*, "(A2)", advance="no") " " + end do + call this%print_value_with_args(obj%keys(j)%obj, indentation + 1, & + .true., maxelems) + write(*, "(A)", advance="no") " => " + call this%print_value_with_args(obj%values(j)%obj, indentation + 1, & + .true., maxelems) + print *, "," + if (maxelems > 0 .and. i > maxelems) then + write(*, "(A3)") "..." + exit printmap + end if + end do printmap + if (.not. sameline) then + do i = 1,indentation + write(*, "(A2)", advance="no") " " + end do + end if + write(*, "(A)") "}," + class is (mp_bin_type) + write(*, "(A)", advance="no") "BIN[" + printbin : do j = 1,obj%numelements() + write(*, "(I0, A)", advance="no") obj%values(j), ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A)") "..." + exit printbin + end if + end do printbin + write(*, "(A)", advance="no") "]" + class is (mp_ext_type) + ind = obj%exttype + 129 ! TODO + write(*, "(A)", advance="no") "EXT[" + printext : do j = 1,obj%numelements() + write(*, "(I0, A)", advance="no") obj%values(j), ", " + if (maxelems > 0 .and. j > maxelems) then + write(*, "(A)") "..." + exit printext + end if + end do printext + write(*, "(A)", advance="no") "]" + end select + if (.not. sameline) then + print *, "" + end if + end subroutine + + subroutine get_size_timestamp(this, osize) + class(mp_timestamp_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%nanoseconds == 0 .and. this%seconds <= 4294967296_int64 .and. & + this%seconds >= 0) then + osize = 6 ! timestamp32 + else if (this%nanoseconds <= 1073741824_int64 & + .and. this%seconds <= 17179869184_int64 & + .and. this%seconds >= 0) then + ! nanoseconds fit into uint30, seconds fit into uint34 + osize = 10 ! timestamp32 + else + osize = 15 ! timestamp96 + end if + end subroutine + + subroutine pack_timestamp(this, buf, num, error) + class(mp_timestamp_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + integer(kind=int64) :: temp + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + select case (num) + case (6) ! timestamp32 + buf(1) = MP_FE4 + buf(2) = MP_TS_EXT + call int_to_bytes_be_4(buf(3:6), int(this%seconds, kind=int32)) + case (10) ! timestamp64 + buf(1) = MP_FE8 + buf(2) = MP_TS_EXT + temp = this%seconds + call mvbits(this%seconds, 0, 34, temp, 0) + call mvbits(this%nanoseconds, 0, 30, temp, 34) + call int_to_bytes_be_8(buf(3:10), temp) + case (15) ! timestamp96 + buf(1) = MP_E8 + buf(2) = 12 + buf(3) = MP_TS_EXT + call int_to_bytes_be_4(buf(4:7), int(this%nanoseconds, kind=int32)) + call int_to_bytes_be_8(buf(8:15), this%seconds) + end select + + error = .false. + end subroutine + + subroutine unpack_timestamp_32(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int32) :: temp + + if (size(buffer(byteadvance+1:)) < 4) then + successful = .false. + return + end if + + temp = bytes_be_to_int_4(buffer(byteadvance+1:byteadvance+4), is_little_endian) + mpv = mp_timestamp_type(temp, 0) + byteadvance = byteadvance + 4 + + successful = .true. + end subroutine + + subroutine unpack_timestamp_64(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: temp, temp1, temp2 + + if (size(buffer(byteadvance+1:)) < 8) then + successful = .false. + return + end if + + temp = bytes_be_to_int_8(buffer(byteadvance+1:byteadvance+8), is_little_endian) + temp1 = 0 + temp2 = 0 + call mvbits(temp, 0, 34, temp1, 0) + call mvbits(temp, 34, 30, temp2, 0) + mpv = mp_timestamp_type(temp1, temp2) + byteadvance = byteadvance + 8 + + successful = .true. + end subroutine + + subroutine unpack_timestamp_96(buffer, byteadvance, is_little_endian, mpv, successful) + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + logical, intent(in) :: is_little_endian + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int32) :: temp + integer(kind=int64) :: temp2 + + if (size(buffer(byteadvance+1:)) < 12) then + successful = .false. + return + end if + + temp = bytes_be_to_int_4(buffer(byteadvance+1:byteadvance+4), is_little_endian) + byteadvance = byteadvance + 4 + temp2 = bytes_be_to_int_8(buffer(byteadvance+1:byteadvance+8), is_little_endian) + mpv = mp_timestamp_type(temp2, temp) + byteadvance = byteadvance + 8 + + successful = .true. + end subroutine + + function is_timestamp(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type(obj) + class is (mp_timestamp_type) + res = .true. + class default + res = .false. + end select + end function is_timestamp + + subroutine get_timestamp_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_timestamp_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_timestamp_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + ! unpacking shenanigans + recursive subroutine check_size(this, buffer, recurse, & + byteadvance, error) + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + logical, intent(in) :: recurse + integer(kind=int64), intent(out) :: byteadvance + logical, intent(out) :: error + + ! temp variables + integer(kind=int64) :: length, i64_temp, i + byte :: i8_temp + integer(kind=int16) :: i16_temp + integer(kind=int32) :: i32_temp + + ! set default output values + error = .false. + byteadvance = 1 + + ! need to have data available to read + length = size(buffer) + if (length == 0) then + error = .true. + this%error_message = 'buffer is empty' + return + end if + + select case(buffer(1)) + case (MP_PFI_L:MP_PFI_H, MP_NIL, MP_T, MP_F) + ! only a single byte is needed, all good + case (MP_U8, MP_I8) + byteadvance = 2 + case (MP_U16, MP_I16, MP_FE1) + byteadvance = 3 + case (MP_FE2) + byteadvance = 4 + case (MP_U32, MP_I32, MP_F32) + byteadvance = 5 + case (MP_FE4) + byteadvance = 6 + case (MP_U64, MP_I64, MP_F64) + byteadvance = 9 + case (MP_FE8) + byteadvance = 10 + case (MP_FE16) + byteadvance = 18 + ! dynamic length values + case (MP_FS_L:MP_FS_H) + ! length in first 5 bits + i8_temp = 0 + call mvbits(buffer(1), 0, 5, i8_temp, 0) ! get fixstr length + byteadvance = 1_int64 + i8_temp + case (MP_S8, MP_B8) + ! length with 1 byte + i32_temp = int8_as_unsigned(buffer(2)) + byteadvance = 1 + i32_temp + case (MP_S16, MP_B16) + ! length with 2 byte + i16_temp = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + byteadvance = 1 + i16_temp + if (length < 1 + byteadvance) then + error = .true. + end if + case (MP_S32, MP_B32) + ! length with 4 byte + i32_temp = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + byteadvance = 1 + i32_temp + if (length < 1 + i32_temp) then + error = .true. + end if + ! containers + case (MP_FA_L:MP_FA_H, MP_FM_L:MP_FM_H) + ! length with first 4 bits + i8_temp = 0 + call mvbits(buffer(1), 0, 4, i8_temp, 0) ! get fixarr, fixmap length + ! recurse + if (recurse) then + do i = 1,i8_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + case (MP_A16, MP_M16) + ! length with 2 byte + byteadvance = 3 + if (length < byteadvance) then + error = .true. + return + end if + i16_temp = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + ! recurse + if (recurse) then + do i = 1,i16_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + case (MP_A32, MP_M32) + ! length with 4 byte + byteadvance = 5 + if (length < byteadvance) then + error = .true. + return + end if + i32_temp = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + ! recurse + if (recurse) then + do i = 1,i32_temp + call this%check_size(buffer(byteadvance+1:), recurse, & + i64_temp, error) + if (error) then + return + end if + byteadvance = byteadvance + i64_temp + end do + end if + end select + if (length < byteadvance) then + error = .false. + end if + if (error) then + this%error_message = 'not enough bytes' + end if + end subroutine + + recursive subroutine unpack_value(this, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(out) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + ! other variables to use + integer(kind=int64) :: length + integer :: i + integer(kind=int64) :: i_64 + byte :: btemp1 ! byte temp value + integer(kind=int16) :: val_int16 + integer(kind=int32) :: val_int32 + integer(kind=int64) :: val_int64 + + integer(kind=int64) :: i64_temp + character(:), allocatable :: val_char + + logical :: error + + length = size(buffer) + + ! set default output values + successful = .true. + + ! need to have data available to read + if (length == 0) then + successful = .false. + this%error_message = 'buffer is empty' + return + end if + + ! check that the size for the entire header exists + call this%check_size(buffer, .true., i64_temp, error) + if (error) then + successful = .false. + this%error_message = 'insufficient size' + return + end if + + byteadvance = 1 ! default output value + select case (buffer(1)) + case (MP_PFI_L:MP_PFI_H) + ! the byte itself is the value + mpv = mp_int_type(buffer(1)) + case (MP_FM_L:MP_FM_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 4, btemp1, 0) ! get fixmap length + val_int64 = btemp1 + byteadvance = 1 + call this%unpack_map(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_FA_L:MP_FA_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 4, btemp1, 0) ! get fixarray length + byteadvance = 1 + call this%unpack_array(btemp1 + 0_int64, buffer, byteadvance, & + mpv, successful) + case (MP_FS_L:MP_FS_H) + btemp1 = 0 + call mvbits(buffer(1), 0, 5, btemp1, 0) ! get fixstr length + allocate(character(btemp1) :: val_char) + do i = 1,btemp1 + val_char(i:i) = transfer(buffer(1 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + btemp1 + case (MP_NIL) + ! default is already nil + mpv = mp_nil_type() + case (MP_NU) + successful = .false. + this%error_message = 'Never Used detected. Invalid MsgPack' + case (MP_F) + mpv = mp_bool_type(.false.) + case (MP_T) + mpv = mp_bool_type(.true.) + ! binary format family + case (MP_B8) + val_int32 = int8_as_unsigned(buffer(2)) + val_int64 = val_int32 + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(3:2+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin8 cast' + end select + byteadvance = 2 + val_int64 + case (MP_B16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int64 = int16_as_unsigned(val_int16) + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(4:3+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin16 bad cast' + end select + byteadvance = 3 + val_int64 + case (MP_B32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + mpv = mp_bin_type(val_int64) + ! copy data + select type (mpv) + class is (mp_bin_type) + mpv%values(:) = buffer(6:5+val_int64) + class default + successful = .false. + this%error_message = 'internal error - bin32 bad cast' + end select + byteadvance = 5 + val_int64 + case (MP_E8) + ! check for first 3 bytes + i = buffer(3) + byteadvance = 3 + call this%unpack_ext(int8_as_unsigned(buffer(2)) + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_E16) + ! check for first 4 bytes + i = buffer(4) + byteadvance = 4 + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + call this%unpack_ext(val_int16 + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_E32) + ! check for first 6 bytes + i = buffer(6) + byteadvance = 6 + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + call this%unpack_ext(val_int32 + 0_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_F32) + ! 4 bytes following + mpv = new_real32(bytes_be_to_real_4(buffer(2:5), & + this%is_little_endian)) + byteadvance = 5 + case (MP_F64) + ! 8 bytes following + mpv = new_real64(bytes_be_to_real_8(buffer(2:9), this%is_little_endian)) + byteadvance = 9 + ! Unsigned integers >>> + ! need to watch when grabbed values are negative + case (MP_U8) + ! 1 byte following + mpv = mp_int_type(int8_as_unsigned(buffer(2))) + byteadvance = 2 + case (MP_U16) + ! 2 bytes following + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + mpv = mp_int_type(int16_as_unsigned(val_int16)) + byteadvance = 3 + case (MP_U32) + ! 4 bytes following + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + mpv = mp_int_type(int32_as_unsigned(val_int32)) + byteadvance = 5 + case (MP_U64) + ! 8 bytes following + val_int64 = bytes_be_to_int_8(buffer(2:9), this%is_little_endian) + if (val_int64 >= 0) then + mpv = mp_int_type(val_int64) + else + mpv = mp_int_type(val_int64) + call set_unsigned(mpv) + end if + byteadvance = 9 + ! Signed integers >>> + case (MP_I8) + ! 1 byte following + mpv = mp_int_type(buffer(2)) + byteadvance = 2 + case (MP_I16) + ! 2 bytes following + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + mpv = mp_int_type(val_int32) + byteadvance = 3 + case (MP_I32) + ! 4 bytes following + mpv = mp_int_type(bytes_be_to_int_4(buffer(2:5), this%is_little_endian)) + byteadvance = 5 + case (MP_I64) + ! 8 bytes following + mpv = mp_int_type(bytes_be_to_int_8(buffer(2:9), this%is_little_endian)) + byteadvance = 9 + ! ext format family + case (MP_FE1) + ! 3 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(1_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE2) + ! 4 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(2_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE4) + ! 6 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(4_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE8) + ! 8 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(8_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_FE16) + ! 18 bytes following + i = buffer(2) + byteadvance = 2 + call this%unpack_ext(16_int64, & + i, buffer, byteadvance, mpv, successful) + case (MP_S8) + val_int16 = int8_as_unsigned(buffer(2)) + ! create string + allocate(character(val_int16) :: val_char) + do i = 1,val_int16 + val_char(i:i) = transfer(buffer(2 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + val_int16 + case (MP_S16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + ! create string + allocate(character(val_int32) :: val_char) + do i = 1,val_int32 + val_char(i:i) = transfer(buffer(3 + i), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1 + val_int32 + case (MP_S32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + ! create string + allocate(character(val_int64) :: val_char) + do i_64 = 1_int64,val_int64 + val_char(i_64:i_64) = transfer(buffer(3 + i_64), 'a') + end do + mpv = mp_str_type(val_char) + byteadvance = 1_int64 + val_int64 + case (MP_A16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + byteadvance = 3 + call this%unpack_array(int(val_int32, kind=int64), & + buffer, byteadvance, mpv, successful) + case (MP_A32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + byteadvance = 5 + call this%unpack_array(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_M16) + val_int16 = bytes_be_to_int_2(buffer(2:3), this%is_little_endian) + val_int32 = int16_as_unsigned(val_int16) + byteadvance = 3 + call this%unpack_map(0_int64 + val_int32, buffer, byteadvance, & + mpv, successful) + case (MP_M32) + val_int32 = bytes_be_to_int_4(buffer(2:5), this%is_little_endian) + val_int64 = int32_as_unsigned(val_int32) + byteadvance = 5 + call this%unpack_map(val_int64, buffer, byteadvance, & + mpv, successful) + case (MP_NFI_L:MP_NFI_H) + ! it's the straight bit pattern there + mpv = mp_int_type(buffer(1)) + end select + end subroutine + + recursive subroutine unpack_array(this, length, buffer, & + byteadvance, mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: i, tmp + class(mp_value_type), allocatable :: val_any + mpv = mp_arr_type(length) + do i = 1,length + call this%unpack_value(buffer(byteadvance+1:), tmp, & + val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + + ! store the newly unpacked object into the array + select type (mpv) + class is (mp_arr_type) + mpv%values(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_array bad cast' + end select + end do + end subroutine + + recursive subroutine unpack_map(this, length, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer(kind=int64) :: i, tmp + class(mp_value_type), allocatable :: val_any + + successful = .true. + mpv = mp_map_type(length) + do i = 1,length + ! get key + call this%unpack_value(buffer(byteadvance+1:), & + tmp, val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + select type (mpv) + class is (mp_map_type) + mpv%keys(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_map bad cast' + end select + + ! get value + call this%unpack_value(buffer(byteadvance+1:), tmp, & + val_any, successful) + byteadvance = byteadvance + tmp + if (.not. successful) then + deallocate(mpv) + return + end if + select type (mpv) + class is (mp_map_type) + mpv%values(i)%obj = val_any + class default + successful = .false. + deallocate(mpv) + print *, "[Error: something went terribly wrong" + end select + end do + end subroutine + + subroutine unpack_ext(this, length, etype, buffer, byteadvance, & + mpv, successful) + class(msgpack) :: this + integer(kind=int64), intent(in) :: length + integer, intent(in) :: etype + byte, dimension(:), intent(in) :: buffer + integer(kind=int64), intent(inout) :: byteadvance + class(mp_value_type), allocatable, intent(out) :: mpv + logical, intent(out) :: successful + + integer :: ind + if (length > size(buffer)) then + successful = .false. + return + end if + + ! Custom extension handling + ind = etype + 129 + if (ind < 1 .or. ind > 256) then + successful = .false. + return + end if + if (length == 1) then + if (this%f1_allocated(ind)) then + call this%f1(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 2) then + if (this%f2_allocated(ind)) then + call this%f2(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 4) then + if (this%f4_allocated(ind)) then + call this%f4(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 8) then + if (this%f8_allocated(ind)) then + call this%f8(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length == 16) then + if (this%f16_allocated(ind)) then + call this%f16(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 256) then + if (this%e8_allocated(ind)) then + call this%e8(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 65536) then + if (this%e16_allocated(ind)) then + call this%e16(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + else if (length < 4294967296_int64) then + if (this%e32_allocated(ind)) then + call this%e32(ind)%cb(buffer, byteadvance, & + this%is_little_endian, mpv, successful) + return + end if + end if + + ! regular extension + mpv = mp_ext_type(etype, length) + successful = .true. + select type(mpv) + class is (mp_ext_type) + mpv%values = buffer(byteadvance+1:byteadvance+length) + byteadvance = byteadvance + length + class default + successful = .false. + deallocate(mpv) + this%error_message = 'internal error - unpack_ext bad cast' + end select + end subroutine +end module diff --git a/src/share/messagepack_value.f90 b/src/share/messagepack_value.f90 new file mode 100644 index 0000000..e3044e1 --- /dev/null +++ b/src/share/messagepack_value.f90 @@ -0,0 +1,1162 @@ +module messagepack_value + use iso_fortran_env + use,intrinsic :: ieee_arithmetic + use byte_utilities + + implicit none + + ! taken directly from https://github.com/msgpack/msgpack/blob/master/spec.md#formats + integer, parameter, public :: MP_PFI_L = 0 ! pos fixint low - 0x00 + integer, parameter, public :: MP_PFI_H = 127 ! pos fixint high - 0x7f + ! because fortran integers are always signed, we are going to perceive values + ! as signed even though they're supposed to be unsigned. + ! the following values are negative as that is how fortran will see them + integer, parameter, public :: MP_FM_L = -128 ! fixmap low - 0x80 + integer, parameter, public :: MP_FM_H = -113 ! fixmap high - 0x8f + integer, parameter, public :: MP_FA_L = -112 ! fixarray low - 0x90 + integer, parameter, public :: MP_FA_H = -97 ! fixarray high - 0x9f + integer, parameter, public :: MP_FS_L = -96 ! fixstr low - 0xa0 + integer, parameter, public :: MP_FS_H = -65 ! fixstr high - 0xbf + integer, parameter, public :: MP_NIL = -64 ! nil - 0xc0 + integer, parameter, public :: MP_NU = -63 ! never used - 0cx1 + integer, parameter, public :: MP_F = -62 ! false - 0xc2 + integer, parameter, public :: MP_T = -61 ! true - 0xc3 + integer, parameter, public :: MP_B8 = -60 ! bin8 - 0xc4 + integer, parameter, public :: MP_B16 = -59 ! bin16 - 0xc5 + integer, parameter, public :: MP_B32 = -58 ! bin32 - 0xc6 + integer, parameter, public :: MP_E8 = -57 ! ext8 - 0xc7 + integer, parameter, public :: MP_E16 = -56 ! ext16 - 0xc8 + integer, parameter, public :: MP_E32 = -55 ! ext32 - 0xc9 + integer, parameter, public :: MP_F32 = -54 ! float32 - 0xca + integer, parameter, public :: MP_F64 = -53 ! float64 - 0xcb + integer, parameter, public :: MP_U8 = -52 ! uint8 - 0xcc + integer, parameter, public :: MP_U16 = -51 ! uint16 - 0xcd + integer, parameter, public :: MP_U32 = -50 ! uint32 - 0xce + integer, parameter, public :: MP_U64 = -49 ! uint64 - 0xcf + integer, parameter, public :: MP_I8 = -48 ! int8 - 0xd0 + integer, parameter, public :: MP_I16 = -47 ! int16 - 0xd1 + integer, parameter, public :: MP_I32 = -46 ! int32 - 0xd2 + integer, parameter, public :: MP_I64 = -45 ! int64 - 0xd3 + integer, parameter, public :: MP_FE1 = -44 ! fixext1 - 0xd4 + integer, parameter, public :: MP_FE2 = -43 ! fixext2 - 0xd5 + integer, parameter, public :: MP_FE4 = -42 ! fixext4 - 0xd6 + integer, parameter, public :: MP_FE8 = -41 ! fixext8 - 0xd7 + integer, parameter, public :: MP_FE16 = -40 ! fixext16 - 0xd8 + integer, parameter, public :: MP_S8 = -39 ! str8 - 0xd9 + integer, parameter, public :: MP_S16 = -38 ! str16 - 0xda + integer, parameter, public :: MP_S32 = -37 ! str32 - 0xdb + integer, parameter, public :: MP_A16 = -36 ! array16 - 0xdc + integer, parameter, public :: MP_A32 = -35 ! array32 - 0xdd + integer, parameter, public :: MP_M16 = -34 ! map16 - 0xde + integer, parameter, public :: MP_M32 = -33 ! map32 - 0xdf + integer, parameter, public :: MP_NFI_L = -32 ! neg fixint low - 0xe0 + integer, parameter, public :: MP_NFI_H = -1 ! neg fixint high - 0xff + + private + + public :: mp_value_type, mp_nil_type, mp_bool_type, mp_int_type, mp_float_type, mp_str_type, mp_bin_type + public :: mp_arr_type, mp_map_type, mp_ext_type + public :: is_nil, is_bool, is_int, is_float, is_str, is_bin, is_arr, is_map, is_ext + public :: new_real32, new_real64 + public :: set_unsigned, is_unsigned + public :: get_bool, get_int, get_real, get_str, get_bin, get_arr_ref, get_map_ref, get_ext_ref + + type, abstract :: mp_value_type + ! nothing here + contains + procedure :: getsize => get_size_1 + procedure :: pack => pack_value + procedure :: numelements => return_one + end type + + ! pointer handler for container types + type :: mp_value_type_ptr + class(mp_value_type), allocatable :: obj + end type + + type, extends(mp_value_type) :: mp_nil_type + ! nothing here + contains + procedure :: getsize => get_size_nil + procedure :: pack => pack_nil + end type + + type, extends(mp_value_type) :: mp_bool_type + ! nothing here + logical :: value + contains + procedure :: getsize => get_size_bool + procedure :: pack => pack_bool + end type + interface mp_bool_type + procedure :: new_bool + end interface mp_bool_type + + type, extends(mp_value_type) :: mp_int_type + ! fortran integers are signed. since MsgPack defines unsigned integers, + ! this needs to handle the case where a uint64 is unpacked, or the user + ! wants to serialize a uint64, which is the only case where this matters + ! the `unsigned` flag will go high when this is detected during unpacking + integer(kind=int64) :: value + logical :: unsigned_64 = .false. + contains + procedure :: getsize => get_size_int + procedure :: pack => pack_int + end type + interface mp_int_type + procedure :: new_int + end interface mp_int_type + + type, extends(mp_value_type) :: mp_float_type + ! simply create memory for both 32bit & 64bit floats + ! with a logical indicating which one is being used + real(kind=real64) :: f64value + real(kind=real32) :: f32value + logical :: is_64 = .false. + contains + procedure :: getsize => get_size_float + procedure :: pack => pack_float + end type + interface mp_float_type + procedure :: new_real32 + procedure :: new_real64 + end interface + + type, extends(mp_value_type) :: mp_str_type + character(:), allocatable :: value + contains + procedure :: getsize => get_size_str + procedure :: pack => pack_str + end type + interface mp_str_type + procedure :: new_str + end interface mp_str_type + + type, extends(mp_value_type) :: mp_bin_type + byte, allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_bin + procedure :: numelements => get_bin_size + procedure :: pack => pack_bin + end type + interface mp_bin_type + procedure :: new_bin + procedure :: new_bin_64 + end interface mp_bin_type + + type, extends(mp_value_type) :: mp_arr_type + class(mp_value_type_ptr), allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_arr + procedure :: numelements => get_arr_size + procedure :: pack => pack_arr + end type + interface mp_arr_type + procedure :: new_arr + procedure :: new_arr_64 + end interface mp_arr_type + + type, extends(mp_value_type) :: mp_map_type + class(mp_value_type_ptr), allocatable, dimension(:) :: keys + class(mp_value_type_ptr), allocatable, dimension(:) :: values + integer(kind=int64) :: ne + contains + procedure :: getsize => get_size_map + procedure :: numelements => get_map_size + procedure :: pack => pack_map + end type + interface mp_map_type + procedure :: new_map + procedure :: new_map_64 + end interface mp_map_type + + type, extends(mp_value_type) :: mp_ext_type + integer :: exttype + byte, allocatable, dimension(:) :: values + contains + procedure :: getsize => get_size_ext + procedure :: numelements => get_ext_size + procedure :: pack => pack_ext + end type + interface mp_ext_type + procedure :: new_ext + end interface mp_ext_type + + contains + subroutine get_size_1(this, osize) + class(mp_value_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + integer function return_zero(obj) + class(mp_value_type) :: obj + return_zero = 0 + end function + + integer(kind=int64) function return_one(obj) + class(mp_value_type) :: obj + return_one = 1_int64 + end function + + subroutine get_size_nil(this, osize) + class(mp_nil_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + subroutine get_size_bool(this, osize) + class(mp_bool_type) :: this + integer(kind=int64), intent(out) :: osize + osize = 1 + end subroutine + + subroutine get_size_int(this, osize) + class(mp_int_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%value < 0) then + if (this%value >= -32) then + osize = 1 ! negative fixint + else if (this%value >= -128) then + osize = 2 ! int8 + else if (this%value >= -32768) then + osize = 3 ! int16 + else if (this%value >= -2147483648_int64) then + osize = 5 ! int32 + else + osize = 9 ! int64 & uint64 + end if + else + if (this%value <= 127) then + osize = 1 ! positive fixint + else if (this%value <= 255) then + osize = 2 ! uint8 + else if (this%value <= 65535) then + osize = 3 ! uint16 + else if (this%value <= 4294967295_int64) then + osize = 5 ! uint32 + else + osize = 9 ! uint64 & int64 + end if + end if + end subroutine + + subroutine get_size_float(this, osize) + class(mp_float_type) :: this + integer(kind=int64), intent(out) :: osize + if (this%is_64) then + osize = 9 ! real64 + else + osize = 5 ! real32 + end if + end subroutine + + integer function get_str_type(length) + ! get type of string based on length of the string + integer(kind=int64), intent(in) :: length + if (length <= 31) then + get_str_type = MP_FS_L + int(length, kind=int8) + else if (length <= 255) then + get_str_type = MP_S8 + else if (length <= 65535) then + get_str_type = MP_S16 + else if (length <= 4294967295_int64) then + get_str_type = MP_S32 + else + get_str_type = MP_NU ! bad + end if + end function + + integer function get_bin_type(length) + ! get type of bin based on length of data + integer(kind=int64), intent(in) :: length + if (length <= 255) then + get_bin_type = MP_B8 + else if (length <= 65535) then + get_bin_type = MP_B16 + else if (length <= 4294967295_int64) then + get_bin_type = MP_B32 + else + get_bin_type = MP_NU ! bad + end if + end function + + integer function get_arr_type(length) + ! get type of array based on length of the array + integer(kind=int64), intent(in) :: length + if (length <= 15) then + get_arr_type = int(ior(MP_FA_L, int(length)), kind=int8) + else if (length <= 65535) then + get_arr_type = MP_A16 + else if (length <= 4294967295_int64) then + get_arr_type = MP_A32 + else + get_arr_type = MP_NU ! bad + end if + end function + + integer function get_map_type(length) + ! get type of map based on length of the map + integer(kind=int64), intent(in) :: length + if (length <= 15) then + get_map_type = int(ior(MP_FM_L, int(length)), kind=int8) + else if (length <= 65535) then + get_map_type = MP_M16 + else if (length <= 4294967295_int64) then + get_map_type = MP_M32 + else + get_map_type = MP_NU ! bad + end if + end function + + integer function get_ext_type(length) + ! get type of extension based on the length + integer(kind=int64), intent(in) :: length + if (length == 1) then + get_ext_type = MP_FE1 + else if (length == 2) then + get_ext_type = MP_FE2 + else if (length == 4) then + get_ext_type = MP_FE4 + else if (length == 8) then + get_ext_type = MP_FE8 + else if (length == 16) then + get_ext_type = MP_FE16 + else if (length <= 255) then + get_ext_type = MP_E8 + else if (length <= 65535) then + get_ext_type = MP_E16 + else if (length <= 4294967295_int64) then + get_ext_type = MP_E32 + else + get_ext_type = MP_NU ! bad + end if + end function + + subroutine get_size_str(this, osize) + class(mp_str_type) :: this + integer(kind=int64), intent(out) :: osize + integer(kind=int64) :: length + length = len(this%value) + select case(get_str_type(length)) + case (MP_FS_L:MP_FS_H) + osize = length + 1 + case (MP_S8) + osize = length + 2 ! str8 + case (MP_S16) + osize = length + 3 ! str16 + case (MP_S32) + osize = length + 5 ! str32 + case default + osize = 0 + print *, "WARNING BAD STRING" + end select + end subroutine + + subroutine get_size_bin(this, osize) + class(mp_bin_type) :: this + integer(kind=int64), intent(out) :: osize + integer :: length + length = size(this%values) + if (length <= 255) then + osize = length + 2 ! bin8 + else if (length <= 65535) then + osize = length + 3 ! bin16 + else + osize = length + 5 ! bin32 + end if + ! TODO handle longer than error case + end subroutine + + subroutine get_size_arr(this, osize) + class(mp_arr_type) :: this + integer(kind=int64), intent(out) :: osize + integer(kind=int64) i, elemsize, length + + length = size(this%values) + ! set initial value + if (length <= 15) then + osize = 1 ! fixarray + else if (length <= 65535) then + osize = 3 ! array16 + else + osize = 5 ! array32 + end if + ! TODO error handling for larger + + ! get sizes of all contained values + do i = 1, length + call this%values(i)%obj%getsize(elemsize) + osize = osize + elemsize + end do + end subroutine + + subroutine get_size_map(this, osize) + class(mp_map_type) :: this + integer(kind=int64), intent(out) :: osize + + integer(kind=int64) keysize, valuesize, i + ! set initialsize + if (this%ne <= 15) then + osize = 1 ! fixmap + else if (this%ne <= 65535) then + osize = 3 ! map16 + else + osize = 5 ! map32 + end if + ! TODO handle errors for larger + + ! get sizes of all contained values + do i = 1, this%ne + call this%keys(i)%obj%getsize(keysize) + call this%values(i)%obj%getsize(valuesize) + osize = osize + keysize + valuesize + end do + end subroutine + + subroutine get_size_ext(this, osize) + class(mp_ext_type) :: this + integer(kind=int64), intent(out) :: osize + integer :: length + + length = size(this%values) + if (length == 1) then + osize = 3 ! fixext1 + else if (length == 2) then + osize = 4 ! fixext2 + else if (length == 4) then + osize = 6 ! fixext4 + else if (length == 8) then + osize = 10 ! fixext8 + else if (length == 16) then + osize = 18 ! fixext16 + else if (length <= 255) then + osize = 3 + length ! ext8 + else if (length <= 65535) then + osize = 4 + length ! ext16 + else + osize = 6 + length ! ext32 + end if + end subroutine + + subroutine pack_value(this, buf, num, error) + class(mp_value_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + print *, "[Error: abstract pack function called" + error = .true. ! this function should never be called + end subroutine + + subroutine pack_nil(this, buf, num, error) + class(mp_nil_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + if (size(buf) < 1) then + error = .true. + return + end if + + buf(1) = MP_NIL + num = 1 + error = .false. + end subroutine + + subroutine pack_bool(this, buf, num, error) + class(mp_bool_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + if (size(buf) < 1) then + error = .true. + return + end if + + if (this%value) then + buf(1) = MP_T + else + buf(1) = MP_F + end if + error = .false. + num = 1 + end subroutine + + subroutine pack_int(this, buf, num, error) + class(mp_int_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + error = .false. + if (this%value < 0) then + if (this%value >= -32) then + ! negative fixint - copy bits over + buf(1) = int(this%value, kind=int8) + else if (this%value >= -128) then + ! int8 + buf(1) = MP_I8 + buf(2) = int(this%value, kind=int8) + else if (this%value >= -32768) then + ! int16 + buf(1) = MP_I16 + call int_to_bytes_be_2(buf(2:3), int(this%value, kind=int16)) + else if (this%value >= -2147483648_int64) then + ! int32 + buf(1) = MP_I32 + call int_to_bytes_be_4(buf(2:5), int(this%value, kind=int32)) + else + if (this%unsigned_64) then + ! uint64 + buf(1) = MP_U64 + else + ! int64 + buf(1) = MP_I64 + end if + call int_to_bytes_be_8(buf(2:9), int(this%value, kind=int64)) + end if + else + if (this%value <= 127) then + buf(1) = int(this%value, kind=int8) + else if (this%value <= 255) then + ! uint8 + buf(1) = MP_U8 + buf(2) = int(this%value, kind=int8) + else if (this%value <= 65535) then + ! uint16 + buf(1) = MP_U16 + call int_to_bytes_be_2(buf(2:3), int(this%value, kind=int16)) + else if (this%value <= 4294967295_int64) then + ! uint32 + buf(1) = MP_U32 + call int_to_bytes_be_4(buf(2:5), int(this%value, kind=int32)) + else + if (this%unsigned_64) then + ! uint64 + buf(1) = MP_U64 + else + ! int64 + buf(1) = MP_I64 + end if + call int_to_bytes_be_8(buf(2:9), int(this%value, kind=int64)) + end if + end if + end subroutine + + subroutine pack_float(this, buf, num, error) + class(mp_float_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize value + if (this%is_64) then + buf(1) = MP_F64 + call real_to_bytes_be_8(buf(2:9), this%f64value) + else + buf(1) = MP_F32 + call real_to_bytes_be_4(buf(2:5), this%f32value) + end if + + error = .false. + end subroutine + + subroutine pack_str(this, buf, num, error) + class(mp_str_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer :: strtype + integer :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = len(this%value) + strtype = get_str_type(length) + buf(1) = int(strtype, kind=int8) ! write marker + + select case(strtype) + case (MP_FS_L:MP_FS_H) + writeindex = 1 + case (MP_S8) + writeindex = 2 + buf(2) = int(length, kind=int8) + case (MP_S16) + writeindex = 3 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_S32) + writeindex = 5 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + end select + do i = 1,length + buf(writeindex+i) = transfer(this%value(i:i), 0_int8) + end do + error = .false. + end subroutine + + subroutine pack_bin(this, buf, num, error) + class(mp_bin_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer :: writeindex + integer :: bintype + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + bintype = get_bin_type(length) + buf(1) = int(bintype, kind=int8) ! write marker + + select case(bintype) + case (MP_B8) + writeindex = 3 + buf(2) = int(length, kind=int8) + case (MP_B16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_B32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + buf(writeindex:writeindex+length-1) = this%values + + error = .false. + end subroutine + + recursive subroutine pack_arr(this, buf, num, error) + class(mp_arr_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length, temp + integer :: arrtype + integer(kind=int64) :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + arrtype = get_arr_type(length) + buf(1) = int(arrtype, kind=int8) ! write marker + + select case(arrtype) + case (MP_FA_L:MP_FA_H) + writeindex = 2 + case (MP_A16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_A32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + do i = 1,length + call this%values(i)%obj%pack(buf(writeindex:), temp, error) + writeindex = writeindex + temp + if (error) then + return + end if + end do + + error = .false. + end subroutine + + recursive subroutine pack_map(this, buf, num, error) + class(mp_map_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length, temp + integer :: maptype + integer(kind=int64) :: writeindex + integer(kind=int64) :: i + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize values + length = this%numelements() + maptype = get_map_type(length) + buf(1) = int(maptype, kind=int8) ! write marker + + select case(maptype) + case (MP_FM_L:MP_FM_H) + writeindex = 2 + case (MP_M16) + writeindex = 4 + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + case (MP_M32) + writeindex = 6 + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + case (MP_NU) + error = .true. + return + end select + do i = 1,length + call this%keys(i)%obj%pack(buf(writeindex:), temp, error) + if (error) then + return + end if + writeindex = writeindex + temp + call this%values(i)%obj%pack(buf(writeindex:), temp, error) + if (error) then + return + end if + writeindex = writeindex + temp + end do + + error = .false. + end subroutine + + subroutine pack_ext(this, buf, num, error) + class(mp_ext_type) :: this + byte, dimension(:) :: buf + integer(kind=int64), intent(out) :: num + logical, intent(out) :: error + + ! check that the buffer can hold the required number of bytes + integer(kind=int64) :: length + integer(kind=int64) :: etype + call this%getsize(num) + if (num > size(buf)) then + error = .true. + return + end if + + ! serialize data + length = this%numelements() + etype = get_ext_type(length) + buf(1) = int(etype, kind=int8) ! write marker + + select case(etype) + case (MP_FE1, MP_FE2, MP_FE4, MP_FE8, MP_FE16) + buf(2) = int(this%exttype, kind=int8) + buf(3:3+length-1) = this%values + case (MP_E8) + buf(2) = int(length, kind=int8) + buf(3) = int(this%exttype, kind=int8) + buf(4:4+length-1) = this%values + case (MP_E16) + call int_to_bytes_be_2(buf(2:3), int(length, kind=int16)) + buf(4) = int(this%exttype, kind=int8) + buf(5:5+length-1) = this%values + case (MP_E32) + call int_to_bytes_be_4(buf(2:5), int(length, kind=int32)) + buf(6) = int(this%exttype, kind=int8) + buf(7:7+length-1) = this%values + case (MP_NU) + error = .true. + return + end select + + error = .false. + end subroutine + + function is_nil(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_nil_type) + res = .true. + class default + res = .false. + end select + end function is_nil + + function is_bool(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_bool_type) + res = .true. + class default + res = .false. + end select + end function is_bool + + function is_int(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_int_type) + res = .true. + class default + res = .false. + end select + end function is_int + + function is_float(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_float_type) + res = .true. + class default + res = .false. + end select + end function is_float + + function is_str(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_str_type) + res = .true. + class default + res = .false. + end select + end function is_str + + function is_bin(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_bin_type) + res = .true. + class default + res = .false. + end select + end function is_bin + + function is_arr(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_arr_type) + res = .true. + class default + res = .false. + end select + end function is_arr + + function is_map(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_map_type) + res = .true. + class default + res = .false. + end select + end function is_map + + function is_ext(obj) result(res) + class(mp_value_type), intent(in) :: obj + logical :: res + + select type (obj) + class is (mp_ext_type) + res = .true. + class default + res = .false. + end select + end function is_ext + + type(mp_bool_type) function new_bool(arg) + logical, intent(in) :: arg + new_bool%value = arg + end function new_bool + + type(mp_int_type) function new_int(arg) + ! generic constructor for integers + integer(kind=int64), intent(in) :: arg + new_int%value = arg + end function new_int + + subroutine set_unsigned(obj) + ! Changes the unsigned_64 flag to true for packing purposes + class(mp_value_type), intent(inout) :: obj + select type (obj) + class is (mp_int_type) + obj%unsigned_64 = .true. + end select + end subroutine + + logical function is_unsigned(obj) + class(mp_value_type), intent(in) :: obj + select type (obj) + class is (mp_int_type) + is_unsigned = obj%unsigned_64 + class default + is_unsigned = .false. + end select + end function + + type(mp_float_type) function new_real32(arg) + real(kind=real32), intent(in) :: arg + new_real32%f32value = arg + new_real32%f64value = 0.0 + new_real32%is_64 = .false. + end function new_real32 + + type(mp_float_type) function new_real64(arg) + real(kind=real64), intent(in) :: arg + new_real64%f32value = 0.0 + new_real64%f64value = arg + new_real64%is_64 = .true. + end function new_real64 + + type(mp_str_type) function new_str(arg) + character(:), allocatable :: arg + new_str%value = arg + end function new_str + + type(mp_bin_type) function new_bin(length) + integer, intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_bin%values(length)) + end function new_bin + + type(mp_bin_type) function new_bin_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_bin_64%values(length)) + end function new_bin_64 + + type(mp_arr_type) function new_arr(length) + integer, intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_arr%values(length)) + end function new_arr + + type(mp_arr_type) function new_arr_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + if (length > 2147483647_int64) then + print *, "[Warning: Allocated array with size greater than packing allows" + end if + allocate(new_arr_64%values(length)) + end function new_arr_64 + + type(mp_map_type) function new_map(length) + integer, intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated map with size greater than packing allows" + end if + allocate(new_map%keys(length)) + allocate(new_map%values(length)) + new_map%ne = length + end function new_map + + type(mp_map_type) function new_map_64(length) + integer(kind=int64), intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated map with size greater than packing allows" + end if + allocate(new_map_64%keys(length)) + allocate(new_map_64%values(length)) + new_map_64%ne = length + end function new_map_64 + + type(mp_ext_type) function new_ext(etype, length) + integer, intent(in) :: etype + integer(kind=int64), intent(in) :: length ! number of elements to allocate + + if (length > 2147483647_int64) then + print *, "[Warning: Allocated ext with size greater than packing allows" + end if + + new_ext%exttype = etype + allocate(new_ext%values(length)) + end function new_ext + + subroutine get_bool(obj, val, stat) + class(mp_value_type), intent(in) :: obj + logical, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_bool_type) + val = obj%value + stat = .true. + class default + val = .false. + stat = .false. + end select + end subroutine + + subroutine get_int(obj, val, stat) + class(mp_value_type), intent(in) :: obj + integer(kind=int64), intent(out) :: val + logical, intent(out) :: stat + ! emulate is_int + select type (obj) + class is (mp_int_type) + val = obj%value + stat = .true. + class default + val = 0 + stat = .false. + end select + end subroutine + + subroutine get_real(obj, val, stat) + class(mp_value_type), intent(in) :: obj + real(kind=real64), intent(out) :: val + logical, intent(out) :: stat + + select type (obj) + class is (mp_float_type) + if (obj%is_64) then + val = obj%f64value + else + val = obj%f32value + end if + stat = .true. + class default + val = 0 + stat = .false. + end select + end subroutine + + subroutine get_str(obj, val, stat) + class(mp_value_type), intent(in) :: obj + character(:), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type (obj) + class is (mp_str_type) + val = obj%value + stat = .true. + class default + val = "" + stat = .false. + end select + end subroutine + + subroutine get_bin(obj, val, stat) + class(mp_value_type), intent(in) :: obj + byte, allocatable, dimension(:), intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_bin_type) + val = obj%values + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_arr_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_arr_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_arr_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_map_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_map_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_map_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + subroutine get_ext_ref(obj, val, stat) + class(mp_value_type), intent(in) :: obj + class(mp_ext_type), allocatable, intent(out) :: val + logical, intent(out) :: stat + + select type(obj) + class is (mp_ext_type) + val = obj + stat = .true. + class default + stat = .false. + end select + end subroutine + + integer(kind=int64) function get_bin_size(obj) + class(mp_bin_type) :: obj + get_bin_size = size(obj%values) + end function + + integer(kind=int64) function get_arr_size(obj) + class(mp_arr_type) :: obj + get_arr_size = size(obj%values) + end function + + integer(kind=int64) function get_map_size(obj) + class(mp_map_type) :: obj + get_map_size = obj%ne + end function + + integer(kind=int64) function get_ext_size(obj) + class(mp_ext_type) :: obj + get_ext_size = size(obj%values) + end function +end module diff --git a/src/share/namelistModule.f90 b/src/share/namelistModule.f90 index 5c41137..b2c582a 100644 --- a/src/share/namelistModule.f90 +++ b/src/share/namelistModule.f90 @@ -1,4 +1,5 @@ module defNamelist + implicit none ! variable definitions @@ -26,6 +27,7 @@ module defNamelist end module defNamelist module namelistModule +use snow_log_module implicit none type, public :: namelist_type @@ -56,21 +58,26 @@ module namelistModule subroutine readNamelist(this, namelist_file) use defNamelist implicit none - + class(namelist_type) :: this ! Optional namelist_file path/filename to read ! if not given, the program looks for 'namelist.input' in run directory as a default character(len=*), intent (in), optional :: namelist_file - - print*, 'Reading namelist' + integer :: ios + ios = 0 + + call write_log("readNameList : reading namelist", LOG_LEVEL_INFO) ! -- open and read namelist file - open(33, file=namelist_file, form="formatted") + open(33, file=namelist_file, form="formatted", IOSTAT=ios) + if (ios /= 0) then + call write_log('Error opening namelist file ' // namelist_file, LOG_LEVEL_FATAL) + end if + read(33, SNOW17_CONTROL) close(33) - print*, ' -- simulating basin ', main_id, ' with ', n_hrus, ' snowbands' - + call write_log('readNameList -- simulating basin ' // main_id // ' with ' // itoa(n_hrus) // ' snowbands', LOG_LEVEL_INFO) ! -- transfer to namelist datatype this%main_id = main_id this%n_hrus = n_hrus @@ -89,9 +96,10 @@ subroutine readNamelist(this, namelist_file) ! -- namelist entry checks -- if (this%warm_start_run .eq. 1 .and. this%write_states .eq. 1) then this%write_states = 0 - print*, ' -- WARNING: cannot read and write state files at the same time. Setting write_states option to 0 and continuing' + call write_log("readNameList - cannot read and write state files at the same time.", LOG_LEVEL_WARNING) + call write_log("Setting write_states option to 0 and continuing", LOG_LEVEL_WARNING) endif end subroutine readNamelist -end module namelistModule \ No newline at end of file +end module namelistModule diff --git a/src/share/runSnow17.f90 b/src/share/runSnow17.f90 index 8f0e86c..dde0236 100644 --- a/src/share/runSnow17.f90 +++ b/src/share/runSnow17.f90 @@ -8,6 +8,9 @@ module runModule use runInfoType use forcingType use modelVarType + use snow_log_module + use messagepack + use iso_fortran_env implicit none @@ -17,6 +20,7 @@ module runModule type(parameters_type) :: parameters type(forcing_type) :: forcing type(modelvar_type) :: modelvar + byte, dimension(:), allocatable :: serialization_buffer end type snow17_type contains @@ -245,7 +249,173 @@ SUBROUTINE cleanup(model) close(model%runinfo%state_fileunits(nh)) end do #endif - + !Free up serialization buffer memory + if(allocated(model%serialization_buffer)) then + deallocate(model%serialization_buffer) + end if + end subroutine cleanup -end module runModule + SUBROUTINE new_serialization_request (model, exec_status) + type(snow17_type), intent(inout) :: model + integer(kind=int64) :: nh !counter for HRUs + real, dimension(:), allocatable :: cs_per_hru + class(msgpack), allocatable :: mp + class(mp_arr_type), allocatable :: mp_sub_arr + class(mp_arr_type), allocatable :: mp_state_arr + class(mp_arr_type), allocatable :: mp_cs_arr + byte, dimension(:), allocatable :: serialization_buffer + integer(kind=int64), intent(out) :: exec_status + + mp = msgpack() + mp_cs_arr = mp_arr_type(model%runinfo%n_hrus) + do nh=1, model%runinfo%n_hrus + cs_per_hru = model%modelvar%cs(:,nh) + mp_sub_arr = mp_arr_type(19) + mp_sub_arr = transfer_values_to_mp(cs_per_hru) + mp_cs_arr%values(nh)%obj = mp_sub_arr + end do + + !Add the time information and the state variables by HRU to the main mp array. + mp_state_arr = mp_arr_type(6) + mp_state_arr%values(1)%obj = mp_int_type(model%runinfo%curr_yr) !curr_yr + mp_state_arr%values(2)%obj = mp_int_type(model%runinfo%curr_mo) !curr_mo + mp_state_arr%values(3)%obj = mp_int_type(model%runinfo%curr_dy) !curr_dy + mp_state_arr%values(4)%obj = mp_int_type(model%runinfo%curr_hr) !curr_hr + mp_state_arr%values(5)%obj = transfer_values_to_mp(model%modelvar%tprev) + mp_state_arr%values(6)%obj = mp_cs_arr + + ! pack the data + call mp%pack_alloc(mp_state_arr, serialization_buffer) + if (mp%failed()) then + call write_log("Serialization using messagepack failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + else + exec_status = 0 + model%serialization_buffer = serialization_buffer + call write_log("Serialization using messagepack successful!", LOG_LEVEL_DEBUG) + end if + END SUBROUTINE new_serialization_request + + SUBROUTINE deserialize_mp_buffer (model, serialized_data,exec_status) + type(snow17_type), intent(inout) :: model + integer , intent(in) :: serialized_data(:) + integer(kind=int64), intent(out) :: exec_status + byte, allocatable :: serialized_data_1b(:) + class(msgpack), allocatable :: mp + class(mp_value_type), allocatable :: mpv + class(mp_arr_type), allocatable :: arr + class(mp_arr_type), allocatable :: arr_tprev_hrus + class(mp_arr_type), allocatable :: arr_cs_hrus + class(mp_arr_type), allocatable :: arr_state + integer(kind=int64) :: nh, yr, mo, dd, hr + logical :: status + + exec_status = 0 + 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 (.NOT. is_arr(mpv)) then + call write_log("Deserialized data structure is not a messagepack array. Error: " // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + return + end if + + !Get a reference to the deserialized data + call get_arr_ref(mpv, arr_state, status) + if (.NOT. status) then + call write_log("Getting an array reference to deserialized data failed! Error: " // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + return + end if + + !Update the start and current time for the runInfo. + call get_int(arr_state%values(1)%obj, yr, status) + model%runinfo%curr_yr = yr + call get_int(arr_state%values(2)%obj, mo, status) + model%runinfo%curr_mo = mo + call get_int(arr_state%values(3)%obj, dd, status) + model%runinfo%curr_dy = dd + call get_int(arr_state%values(4)%obj, hr, status) + model%runinfo%curr_hr = hr + + !Get a reference to the deserialized data for model variable 'tprev' + call get_arr_ref(arr_state%values(5)%obj,arr_tprev_hrus,status) + if(.NOT. status) then + call write_log("Deserializing data for model variable 'tprev' failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + return + end if + + !Next check: The number of elements in the serialized HRU data array for tprev is expected to match the + !number of HRUs. Check here and log if they are not equal. + if (arr_tprev_hrus%numelements() .NE. model%runinfo%n_hrus) then + call write_log("The serialized data for model variable 'tprev' does not contain state information for all HRUs. Please check inputs", LOG_LEVEL_FATAL) + exec_status = 1 + return + else + model%modelvar%tprev = transfer_values_from_mp(arr_tprev_hrus) + end if + + !Get a reference to the deserialized data for model variable 'cs' + call get_arr_ref(arr_state%values(6)%obj,arr_cs_hrus,status) + if(.NOT. status) then + call write_log("Deserializing data for model variable 'cs' failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + return + end if + + !Next check: The number of elements in the serialized HRU data array for cs is expected to match the + !number of HRUs. Check here and log if they are not equal. + if (arr_cs_hrus%numelements() .NE. model%runinfo%n_hrus) then + call write_log("The serialized data model variable 'cs' does not contain state information for all HRUs. Please check inputs", LOG_LEVEL_FATAL) + exec_status = 1 + return + end if + + !Loop through each HRU and update the cs variable + do nh=1, model%runinfo%n_hrus + call get_arr_ref(arr_cs_hrus%values(nh)%obj,arr,status) + if (.NOT. status) then + call write_log("Deserialization using messagepack (HRU internal array) for variable 'cs' failed!. Error:" // mp%error_message, LOG_LEVEL_FATAL) + exec_status = 1 + return + else + model%modelvar%cs(:,nh) = transfer_values_from_mp(arr) + end if + end do + deallocate (mpv) + deallocate (serialized_data_1b) + + END SUBROUTINE deserialize_mp_buffer + + FUNCTION transfer_values_to_mp (src) RESULT (dest) + + real, allocatable, dimension(:), intent(in) :: src + class(mp_arr_type), allocatable :: dest + integer(kind=int64) :: index + + do index=LBOUND(src,1), UBOUND(src,1) + dest%values(index)%obj = mp_float_type(src(index)) + end do + + END FUNCTION transfer_values_to_mp + + FUNCTION transfer_values_from_mp (src) RESULT (dest) + + class(mp_arr_type), allocatable, intent(in) :: src + real, allocatable, dimension(:) :: dest + real(kind=real64) :: deserialized_val + integer(kind=int64) :: index + logical :: status + + do index=1, src%numelements() + call get_real(src%values(index)%obj, deserialized_val, status) + dest(index) = deserialized_val + end do + + END FUNCTION transfer_values_from_mp + +end module runModule diff --git a/src/share/snowLogger.f90 b/src/share/snowLogger.f90 new file mode 100644 index 0000000..6b9f202 --- /dev/null +++ b/src/share/snowLogger.f90 @@ -0,0 +1,339 @@ +module snow_log_module + implicit none + + 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= + ! SNOW17_LOGLEVEL= + ! + ! Constants character(len=1), parameter :: DS = "/" + character(len=16), parameter :: MODULE_NAME = "Snow-17" + 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 = "SNOW17_LOGFILEPATH" + character(len=16), parameter :: EV_MODULE_LOGLEVEL = "SNOW17_LOGLEVEL" + character(len=7), parameter :: log_module_name = "SNOW17" + 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