diff --git a/build/mkdeps.sh b/build/mkdeps.sh index ffee0bd..b0f06d3 100755 --- a/build/mkdeps.sh +++ b/build/mkdeps.sh @@ -14,7 +14,7 @@ # files=`ls $1/*.F90` for src in $files; do - deps=`awk '/^\s*[Uu][Ss][Ee] / {gsub ( "[:,]","" ) ; print $2}' $src | sort | uniq` + deps=`awk '/^\s*[Uu][Ss][Ee] / {gsub ( "[:,]","" ) ; print tolower($2)}' $src | sort | uniq` fname=`basename $src .F90` output="$2/${fname}.o: $src" for dep in $deps; do diff --git a/python/amunpy/setup.py b/python/amunpy/setup.py index 1b58407..567d122 100644 --- a/python/amunpy/setup.py +++ b/python/amunpy/setup.py @@ -5,7 +5,7 @@ with open("README.md", "r", encoding="utf-8") as fh: setuptools.setup( name="amunpy", - version="0.9.10", + version="0.9.11", author="Grzegorz Kowal", author_email="grzegorz@amuncode.org", description="Python Interface for the AMUN code's snapshots", diff --git a/python/amunpy/src/amunpy/__init__.py b/python/amunpy/src/amunpy/__init__.py index d4533a4..62fa7eb 100644 --- a/python/amunpy/src/amunpy/__init__.py +++ b/python/amunpy/src/amunpy/__init__.py @@ -21,6 +21,6 @@ __all__ = [ 'AmunXML', 'AmunH5', 'WriteVTK', \ __author__ = "Grzegorz Kowal" __copyright__ = "Copyright 2018-2023 Grzegorz Kowal " -__version__ = "0.9.10" +__version__ = "0.9.11" __maintainer__ = "Grzegorz Kowal" __email__ = "grzegorz@amuncode.org" diff --git a/python/amunpy/src/amunpy/amunxml.py b/python/amunpy/src/amunpy/amunxml.py index 14c48d3..bf364b9 100644 --- a/python/amunpy/src/amunpy/amunxml.py +++ b/python/amunpy/src/amunpy/amunxml.py @@ -272,14 +272,14 @@ class AmunXML(Amun): else: raise Exception("Binary file '{}' compressed in unsupported format {}!".format(fname, comp)) - if 'data_filter' in self.binaries[dataset]: - data_filter = self.binaries[dataset]['data_filter'] - if data_filter == 'bytedelta': + if 'data_encoder' in self.binaries[dataset]: + data_encoder = self.binaries[dataset]['data_encoder'] + if data_encoder == 'bytedelta': data = self.__bytedelta_decode(data, dtype=dtype) - elif data_filter == 'shuffle': + elif data_encoder == 'shuffle': data = self.__shuffle_decode(data, dtype=dtype) else: - raise Exception("Binary file '{}' processed using unsupported filter {}!".format(fname, data_filter)) + raise Exception("Binary file '{}' processed using unsupported data encoder {}!".format(fname, data_encoder)) if 'digest' in self.binaries[dataset]: htype = self.binaries[dataset]['digest_type'] @@ -329,14 +329,14 @@ class AmunXML(Amun): else: raise Exception("Binary file '{}' compressed in unsupported format {}!".format(fname, comp)) - if 'data_filter' in self.chunks[chunk_number][dataset_name]: - data_filter = self.chunks[chunk_number][dataset_name]['data_filter'] - if data_filter == 'bytedelta': + if 'data_encoder' in self.chunks[chunk_number][dataset_name]: + data_encoder = self.chunks[chunk_number][dataset_name]['data_encoder'] + if data_encoder == 'bytedelta': data = self.__bytedelta_decode(data, dtype=dtype) - elif data_filter == 'shuffle': + elif data_encoder == 'shuffle': data = self.__shuffle_decode(data, dtype=dtype) else: - raise Exception("Binary file '{}' processed using unsupported filter {}!".format(fname, data_filter)) + raise Exception("Binary file '{}' processed using unsupported data encoder {}!".format(fname, data_encoder)) if 'digest' in self.chunks[chunk_number][dataset_name]: htype = self.chunks[chunk_number][dataset_name]['digest_type'] diff --git a/sources/compression.F90 b/sources/compression.F90 index 7a2bc5f..98a7ef4 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -29,6 +29,9 @@ ! module compression + use iso_c_binding + use iso_fortran_env + implicit none ! interfaces to compression algorithms @@ -40,92 +43,196 @@ module compression bind(C, name="ZSTD_compressBound") use iso_c_binding, only: c_size_t implicit none - integer(kind=c_size_t), value :: srcSize + integer(c_size_t), value :: srcSize end function zstd_bound - integer(c_size_t) function zstd_compress(dst, dstCapacity, & + integer(c_int) function zstd_iserror(code) & + bind(C, name="ZSTD_isError") + use iso_c_binding, only: c_int, c_size_t + implicit none + integer(c_size_t), value :: code + end function zstd_iserror + + integer(c_size_t) function zstd_compress(dst, dstCapacity, & src, srcSize, level) & bind(C, name="ZSTD_compress") use iso_c_binding, only: c_size_t, c_int, c_ptr implicit none - integer(kind=c_size_t), value :: srcSize, dstCapacity - type(c_ptr) , value :: src, dst - integer(kind=c_int) , value :: level + type(c_ptr) , value :: src, dst + integer(c_size_t), value :: srcSize, dstCapacity + integer(c_int) , value :: level end function zstd_compress - integer(kind=c_int) function zstd_iserror(code) bind(C, name="ZSTD_isError") - use iso_c_binding, only: c_int, c_size_t + integer(c_size_t) function zstd_decompress(dst, dstCapacity, & + src, compressedSize) & + bind(C, name="ZSTD_decompress") + use iso_c_binding, only: c_size_t, c_int, c_ptr implicit none - integer(kind=c_size_t), value :: code - end function zstd_iserror + type(c_ptr) , value :: src, dst + integer(c_size_t), value :: dstCapacity, compressedSize + end function zstd_decompress end interface #endif /* ZSTD */ #ifdef LZ4 interface - integer(kind=c_size_t) function lz4_bound(srcSize, prefsPtr) & - bind(C, name="LZ4F_compressFrameBound") + integer(c_size_t) function lz4_bound(srcSize, preferencesPtr) & + bind(C, name="LZ4F_compressFrameBound") use iso_c_binding, only: c_size_t, c_ptr implicit none - integer(kind=c_size_t), value :: srcSize - type(c_ptr) , value :: prefsPtr + integer(c_size_t), value :: srcSize + type(c_ptr) , value :: preferencesPtr end function lz4_bound - integer(kind=c_size_t) function lz4_compress(dst, dstCapacity, & - src, srcSize, prefsPtr) & - bind(C, name="LZ4F_compressFrame") - use iso_c_binding, only: c_size_t, c_ptr - implicit none - integer(kind=c_size_t), value :: dstCapacity, srcSize - type(c_ptr) , value :: src, dst, prefsPtr - end function lz4_compress - - integer(kind=c_int) function lz4_iserror(code) bind(C, name="LZ4F_isError") + integer(c_int) function lz4_iserror(code) & + bind(C, name="LZ4F_isError") use iso_c_binding, only: c_int, c_size_t implicit none - integer(kind=c_size_t), value :: code + integer(c_size_t), value :: code end function lz4_iserror + integer(c_size_t) function lz4_createDecompressionCtx(dctxPtr, version) & + bind(C, name="LZ4F_createDecompressionContext") + use iso_c_binding, only: c_size_t, c_int, c_ptr + type(c_ptr) , value :: dctxPtr + integer(c_int), value :: version + end function lz4_createDecompressionCtx + + integer(c_size_t) function lz4_freeDecompressionCtx(dctxPtr) & + bind(C, name="LZ4F_freeDecompressionContext") + use iso_c_binding, only: c_size_t, c_ptr + type(c_ptr) , value :: dctxPtr + end function lz4_freeDecompressionCtx + + integer(c_size_t) function lz4_compress(dstBuffer, dstCapacity, & + srcBuffer, srcSize, & + preferencesPtr) & + bind(C, name="LZ4F_compressFrame") + use iso_c_binding, only: c_size_t, c_ptr + implicit none + integer(c_size_t), value :: dstCapacity, srcSize + type(c_ptr) , value :: dstBuffer, srcBuffer + type(c_ptr) , value :: preferencesPtr + end function lz4_compress + + integer(c_size_t) function lz4_decompress(dctxPtr, dst, dstSizePtr, & + src, srcSizePtr, dOptPtr) & + bind(C, name="LZ4F_decompress") + use iso_c_binding, only: c_size_t, c_ptr + implicit none + type(c_ptr), value :: dctxPtr, dst, dstSizePtr, src, srcSizePtr, dOptPtr + end function lz4_decompress + end interface #endif /* LZ4 */ #ifdef LZMA interface - integer(c_int) function lzma_compress(preset, check, allocator, & - src, srcSize, & - dst, dstPos, dstCapacity) & - bind(C, name="lzma_easy_buffer_encode") - use iso_c_binding, only: c_int, c_size_t, c_ptr + integer(c_size_t) function lzma_bound(uncompressed_size) & + bind(C, name="lzma_stream_buffer_bound") + use iso_c_binding, only : c_size_t implicit none - integer(c_int) , value :: preset, check - integer(kind=c_size_t), value :: srcSize, dstCapacity - type(c_ptr) , value :: allocator, src, dst, dstPos + integer(c_size_t), value :: uncompressed_size + end function lzma_bound + + integer(c_int) function lzma_compress(preset, check, allocator, & + in, in_size, out, out_pos, out_size) & + bind(C, name="lzma_easy_buffer_encode") + use iso_c_binding, only: c_int, c_int32_t, c_size_t, c_ptr + implicit none + type(c_ptr) , value :: allocator, in, out, out_pos + integer(c_int32_t), value :: preset + integer(c_int) , value :: check + integer(c_size_t) , value :: in_size, out_size end function lzma_compress + integer(c_int) function lzma_decompress(memlimit, flags, allocator, & + input, inputpos, inputsize, & + output, outputpos, outputsize) & + bind(C, name="lzma_stream_buffer_decode") + use iso_c_binding, only: c_int, c_int32_t, c_size_t, c_ptr + implicit none + type(c_ptr) , value :: memlimit, allocator + type(c_ptr) , value :: input, output, inputpos, outputpos + integer(c_int32_t), value :: flags + integer(c_size_t) , value :: inputsize, outputsize + end function lzma_decompress + end interface #endif /* LZMA */ -! supported compression formats +#ifdef LZ4 + type LZ4F_frameInfo_t + integer(c_int) :: blockSizeID, blockMode, contentChecksumFlag, frameType + integer(c_size_t) :: contentSize + integer(c_int) :: dictID, blockChecksumFlag + end type + + type LZ4F_preferences_t + type(LZ4F_frameInfo_t) :: frameInfo + integer(c_int) :: compressionLevel, autoFlush, favorDecSpeed, reserved(3) + end type + + type LZ4F_decompressOptions_t + integer(c_int) :: stableDst, skipChecksums, reserved(2) + end type +#endif /* LZ4 */ + +#ifdef LZMA + enum, bind(c) + enumerator :: LZMA_OK = 0 + enumerator :: LZMA_STREAM_END + enumerator :: LZMA_NO_CHECK + enumerator :: LZMA_UNSUPPORTED_CHECK + enumerator :: LZMA_GET_CHECK + enumerator :: LZMA_MEM_ERROR + enumerator :: LZMA_MEMLIMIT_ERROR + enumerator :: LZMA_FORMAT_ERROR + enumerator :: LZMA_OPTIONS_ERROR + enumerator :: LZMA_DATA_ERROR + enumerator :: LZMA_BUF_ERROR + enumerator :: LZMA_PROG_ERROR + + end enum + enum, bind(c) + enumerator :: LZMA_CHECK_NONE = 0 + enumerator :: LZMA_CHECK_CRC32 + enumerator :: LZMA_CHECK_CRC64 = 4 + enumerator :: LZMA_CHECK_SHA256 = 10 + end enum +#endif /* LZMA */ + +#ifdef LZ4 + type(LZ4F_preferences_t), target :: prefs +#endif /* LZ4 */ + +! supported compressors ! enum, bind(c) - enumerator compression_none - enumerator compression_zstd - enumerator compression_lz4 - enumerator compression_lzma + enumerator :: compressor_unkn = -1 + enumerator :: compressor_none = 0 + enumerator :: compressor_zstd + enumerator :: compressor_lz4 + enumerator :: compressor_lzma end enum -! compression parameters +! supported data encoders ! - integer(kind(compression_none)), save :: compression_format = 0 - integer , save :: compression_level = 0 - character(len=4) , save :: compression_suffix = '' + enum, bind(c) + enumerator :: encoder_unkn = -1 + enumerator :: encoder_none = 0 + enumerator :: encoder_shuffle + enumerator :: encoder_bytedelta + end enum private - public :: set_compression, get_compression, compression_bound - public :: compression_none, compression_suffix - public :: encode, compress + public :: check_compressor, is_compressor_on + public :: get_compressor_id, get_compressor_name, get_compressed_file_suffix + public :: compression_bound, compress, decompress + public :: check_encoder, is_encoder_on + public :: get_encoder_id, get_encoder_name, encode, decode !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -139,125 +246,268 @@ module compression ! !=============================================================================== ! -! subroutine SET_COMPRESSION: -! -------------------------- +! subroutine CHECK_COMPRESSOR: +! --------------------------- ! -! Subroutine sets the compression format and level. +! Subroutine sets the compressor ID and the compression level based on +! the compressor name. ! ! Arguments: ! -! cformat - the compression format string; -! clevel - the compression level; +! compressor_name - the compressor name; +! compressor_id - the compressor ID; +! compression_level - the compression level; ! !=============================================================================== ! - subroutine set_compression(cformat, clevel) + subroutine check_compressor(compressor_name, compressor_id, & + compression_level) implicit none - character(len=*) , intent(inout) :: cformat - integer , intent(in) :: clevel + character(len=*) , intent(in ) :: compressor_name + integer , intent( out) :: compressor_id + integer , intent(inout) :: compression_level !------------------------------------------------------------------------------- ! - select case(trim(adjustl(cformat))) + select case(trim(adjustl(compressor_name))) #ifdef ZSTD - case("zstd", "ZSTD", "zst", "ZST", "Zstandard") - cformat = "zstd" - compression_format = compression_zstd - compression_level = max(0, min(19, clevel)) - compression_suffix = ".zst" + case("zstd", "ZSTD", "zst", "ZST", "zstandard", "Zstandard") + compressor_id = compressor_zstd + if (compression_level < -19 .or. & + compression_level > 19) compression_level = 3 #endif /* ZSTD */ #ifdef LZ4 - case("lz4", "LZ4") - cformat = "lz4" - compression_format = compression_lz4 - compression_level = max(1, min(12, clevel)) - compression_suffix = ".lz4" + case("lz4", "LZ4", "lz4hc", "LZ4HC") + compressor_id = compressor_lz4 + if (compression_level < -12 .or. & + compression_level > 12) compression_level = 0 + + prefs%frameInfo%blockSizeID = 0 + prefs%frameInfo%blockMode = 0 + prefs%frameInfo%contentChecksumFlag = 1 + prefs%frameInfo%frameType = 0 + prefs%frameInfo%contentSize = 0 + prefs%frameInfo%dictID = 0 + prefs%frameInfo%blockChecksumFlag = 0 + + prefs%compressionLevel = compression_level + prefs%autoFlush = 1 + prefs%favorDecSpeed = 1 + prefs%reserved = 0 #endif /* LZ4 */ #ifdef LZMA case("lzma", "LZMA", "xz", "XZ") - cformat = "lzma" - compression_format = compression_lzma - compression_level = max(0, min(9, clevel)) - compression_suffix = ".xz" + compressor_id = compressor_lzma + if (compression_level < 0 .or. & + compression_level > 9) compression_level = 6 #endif /* LZMA */ case default - cformat = "none" - compression_format = compression_none - compression_level = clevel - compression_suffix = "" + compressor_id = compressor_none end select !------------------------------------------------------------------------------- ! - end subroutine set_compression + end subroutine check_compressor ! !=============================================================================== ! -! function GET_COMPRESSION: -! ------------------------ +! function IS_COMPRESSOR_ON: +! ------------------------- ! -! Function returns the compression format index. +! The function determines if any compression is used. ! +! Arguments: +! +! compressor_id - the compressor ID; ! !=============================================================================== ! - integer function get_compression() + logical function is_compressor_on(compressor_id) implicit none + integer, intent(in) :: compressor_id + !------------------------------------------------------------------------------- ! - get_compression = compression_format + is_compressor_on = compressor_id /= compressor_none return !------------------------------------------------------------------------------- ! - end function get_compression + end function is_compressor_on +! +!=============================================================================== +! +! function GET_COMPRESSOR_ID: +! -------------------------- +! +! Function returns the compressor ID based on its name. +! +! Arguments: +! +! compressor - the compressor name; +! +!=============================================================================== +! + integer function get_compressor_id(compressor) result(compressor_id) + + use helpers, only : print_message + + implicit none + + character(len=*), intent(in) :: compressor + + character(len=*), parameter :: loc = "COMPRESSION::get_compressor_id()" + +!------------------------------------------------------------------------------- +! + select case(trim(adjustl(compressor))) +#ifdef ZSTD + case("zstd", "ZSTD", "zst", "ZST", "zstandard", "Zstandard") + compressor_id = compressor_zstd +#endif /* ZSTD */ +#ifdef LZ4 + case("lz4", "LZ4", "lz4hc", "LZ4HC") + compressor_id = compressor_lz4 +#endif /* LZ4 */ +#ifdef LZMA + case("lzma", "LZMA", "xz", "XZ") + compressor_id = compressor_lzma +#endif /* LZMA */ + case("none") + compressor_id = compressor_none + case default + compressor_id = compressor_unkn + call print_message(loc, "Unsupported compressor '" // & + trim(compressor) // "'.") + end select + + return + +!------------------------------------------------------------------------------- +! + end function get_compressor_id +! +!=============================================================================== +! +! function GET_COMPRESSOR_NAME: +! ---------------------------- +! +! Function returns the name of the compressor. +! +! Arguments: +! +! compressor_id - the compressor ID; +! +!=============================================================================== +! + character(len=4) function get_compressor_name(compressor_id) + + implicit none + + integer, intent(in) :: compressor_id + +!------------------------------------------------------------------------------- +! + select case(compressor_id) + case(compressor_zstd) + get_compressor_name = 'zstd' + case(compressor_lz4) + get_compressor_name = 'lz4' + case(compressor_lzma) + get_compressor_name = 'lzma' + case default + get_compressor_name = 'none' + end select + return + +!------------------------------------------------------------------------------- +! + end function get_compressor_name +! +!=============================================================================== +! +! function GET_COMPRESSED_FILE_SUFFIX: +! ----------------------------------- +! +! Function returns the filename suffix for the compressor. +! +! Arguments: +! +! compressor_id - the compressor ID; +! +!=============================================================================== +! + character(len=4) function get_compressed_file_suffix(compressor_id) + + implicit none + + integer, intent(in) :: compressor_id + +!------------------------------------------------------------------------------- +! + select case(compressor_id) + case(compressor_zstd) + get_compressed_file_suffix = '.zst' + case(compressor_lz4) + get_compressed_file_suffix = '.lz4' + case(compressor_lzma) + get_compressed_file_suffix = '.xz' + case default + get_compressed_file_suffix = '' + end select + return + +!------------------------------------------------------------------------------- +! + end function get_compressed_file_suffix ! !=============================================================================== ! ! function COMPRESSION_BOUND: ! -------------------------- ! -! Function returns the minimum buffer size required to perform -! the compression. +! Function returns the minimum size of the buffer required to compress data. ! ! Arguments: ! -! ilen - the length of the sequence of bytes to compress; +! compressor_id - the compressor ID; +! level - the compression level; +! uncompressed_bytes - the length of the uncompressed sequence of bytes; ! !=============================================================================== ! - integer(kind=8) function compression_bound(ilen) - - use iso_c_binding, only: c_loc + integer(c_size_t) function compression_bound(compressor_id, level, & + uncompressed_bytes) implicit none - integer(kind=8), intent(in) :: ilen - -#ifdef LZ4 - integer, dimension(14), target :: prefs = [5, 0, 1, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0] -#endif /* LZ4 */ + integer , intent(in) :: compressor_id, level + integer(c_size_t), intent(in) :: uncompressed_bytes !------------------------------------------------------------------------------- ! - select case(compression_format) + select case(compressor_id) #ifdef ZSTD - case(compression_zstd) - compression_bound = zstd_bound(ilen) + case(compressor_zstd) + compression_bound = zstd_bound(uncompressed_bytes) #endif /* ZSTD */ #ifdef LZ4 - case(compression_lz4) - prefs(5:6) = transfer(ilen, [ 0_4 ]) - prefs(9) = compression_level - compression_bound = lz4_bound(ilen, c_loc(prefs)) + case(compressor_lz4) + prefs%frameInfo%contentSize = uncompressed_bytes + prefs%compressionLevel = level + + compression_bound = lz4_bound(uncompressed_bytes, c_loc(prefs)) #endif /* LZ4 */ +#ifdef LZMA + case(compressor_lzma) + compression_bound = lzma_bound(uncompressed_bytes) +#endif /* LZMA */ case default - compression_bound = ilen + compression_bound = uncompressed_bytes end select return @@ -275,65 +525,89 @@ module compression ! ! Arguments: ! -! input - the pointer to the input sequence of bytes; -! ilen - the length of input; -! buffer - the buffer where the compression is done; -! clen - the length of buffer in bytes; once the compression was -! successful, it returns the length of the compressed stream; +! compressor_id - the compressor ID; +! level - the compression level; +! input - the pointer to the input sequence of bytes; +! ilen - the length of input; +! buffer - the buffer where the compression is done; +! clen - the length of buffer in bytes; once the compression was +! successful, it returns the length of the compressed stream; ! !=============================================================================== ! - subroutine compress(input, ilen, buffer, clen) - - use iso_c_binding, only : c_int, c_loc, c_ptr -#ifdef LZ4 - use iso_c_binding, only : c_null_ptr -#endif /* LZ4 */ + subroutine compress(compressor_id, level, input, ilen, buffer, clen) implicit none + integer , intent(in) :: compressor_id, level type(c_ptr) , intent(in) :: input integer(kind=8), intent(in) :: ilen type(c_ptr) , intent(inout) :: buffer integer(kind=8), intent(inout) :: clen -#ifdef LZ4 - integer, dimension(14), target :: prefs = [5, 0, 1, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0] -#endif /* LZ4 */ -#ifdef LZMA - integer(kind=8), target :: lsize - integer :: ret -#endif /* LZMA */ + integer(c_size_t), target :: bytes + integer(c_int) :: ret !------------------------------------------------------------------------------- ! - select case(compression_format) + select case(compressor_id) #ifdef ZSTD - case(compression_zstd) - clen = zstd_compress(buffer, clen, input, ilen, compression_level) - if (zstd_iserror(clen) /= 0) clen = 0 + case(compressor_zstd) + bytes = zstd_compress(buffer, clen, input, ilen, level) + ret = zstd_iserror(bytes) + if (ret == 0) then + clen = bytes + else + write(error_unit,"(a,i0,a)") "ZSTD: Unknown error (", ret, ")." + clen = 0_8 + end if #endif /* ZSTD */ #ifdef LZ4 - case(compression_lz4) - prefs(5:6) = transfer(ilen, [ 0_4 ]) - prefs(9) = compression_level - clen = lz4_compress(buffer, clen, input, ilen, c_loc(prefs)) - if (lz4_iserror(clen) /= 0) clen = 0 + case(compressor_lz4) + prefs%frameInfo%contentSize = ilen + prefs%compressionLevel = level + + bytes = lz4_compress(buffer, clen, input, ilen, c_loc(prefs)) + ret = lz4_iserror(bytes) + if (ret == 0) then + clen = bytes + else + write(error_unit,"(a,i0,a)") "LZ4: Unknown error (", ret, ")." + clen = 0_8 + end if #endif /* LZ4 */ #ifdef LZMA - case(compression_lzma) - lsize = 0 - ret = lzma_compress(compression_level, 4, c_null_ptr, & - input, ilen, buffer, c_loc(lsize), clen) - if (ret > 0) then - clen = 0 + case(compressor_lzma) + bytes = 0_8 + ret = lzma_compress(level, LZMA_CHECK_CRC64, c_null_ptr, & + input, ilen, buffer, c_loc(bytes), clen) + if (ret == LZMA_OK) then + clen = bytes + else if (ret == LZMA_UNSUPPORTED_CHECK) then + write(error_unit,"(a)") "LZMA: Cannot calculate the integrity check." + clen = 0_8 + else if (ret == LZMA_MEM_ERROR) then + write(error_unit,"(a)") "LZMA: Cannot allocate memory." + clen = 0_8 + else if (ret == LZMA_OPTIONS_ERROR) then + write(error_unit,"(a)") "LZMA: Invalid or unsupported options." + clen = 0_8 + else if (ret == LZMA_DATA_ERROR) then + write(error_unit,"(a)") "LZMA: Data is corrupt." + clen = 0_8 + else if (ret == LZMA_BUF_ERROR) then + write(error_unit,"(a)") "LZMA: Not enough output buffer space." + clen = 0_8 + else if (ret == LZMA_PROG_ERROR) then + write(error_unit,"(a)") "LZMA: Programming error." + clen = 0_8 else - clen = lsize + write(error_unit,"(a,i0,a)") "LZMA: Unknown error (", ret, ")." + clen = 0_8 end if #endif /* LZMA */ case default - clen = 0 + clen = 0_8 end select !------------------------------------------------------------------------------- @@ -342,6 +616,296 @@ module compression ! !=============================================================================== ! +! subroutine DECOMPRESS: +! --------------------- +! +! This subroutine is responsible for decompressing the input buffer using +! the specified compression method. +! +! Arguments: +! +! compressor_id - an identifier for the compression algorithm to be used; +! input_ptr - a pointer to the start of the input compressed +! byte sequence. +! input_bytes - the length of the input compressed sequence; +! output_ptr - the destination where the decompressed data +! will be written; +! output_bytes - the length of the output buffer in bytes; +! status - a flag indicating the status of the subroutine; +! +!=============================================================================== +! + subroutine decompress(compressor_id, input_ptr, input_bytes, & + output_ptr, output_bytes, status) + + use helpers, only : print_message + + implicit none + + integer , intent(in ) :: compressor_id + type(c_ptr) , intent(in ) :: input_ptr + integer(kind=8), intent(in ) :: input_bytes + type(c_ptr) , intent(in ) :: output_ptr + integer(kind=8), intent(in ) :: output_bytes + integer , intent( out) :: status + + character(len=*) , parameter :: loc = "COMPRESSION::decompress()" +#ifdef LZMA + integer(c_size_t), parameter :: MiB = 1048576 +#endif /* LZMA */ + + integer(c_size_t) , target :: dbytes +#if defined LZ4 || defined LZMA + integer(c_size_t) , target :: ibytes +#endif /* LZ4 || LZMA */ +#ifdef LZ4 + type(LZ4F_decompressOptions_t), target :: dOpt + type(c_ptr) , target :: dctxPtr + integer(c_size_t) , target :: res +#endif /* LZ4 */ +#ifdef LZMA + integer(c_size_t) , target :: memlim + integer(c_int) :: ret +#endif /* LZMA */ + +!------------------------------------------------------------------------------- +! + status = 0 + + select case(compressor_id) +#ifdef ZSTD + case(compressor_zstd) + dbytes = zstd_decompress(output_ptr, output_bytes, input_ptr, input_bytes) + if (zstd_iserror(dbytes) /= 0) then + call print_message(loc, "ZSTD decompression failure.") + status = -1 + end if +#endif /* ZSTD */ +#ifdef LZ4 + case(compressor_lz4) + res = lz4_createDecompressionCtx(c_loc(dctxPtr), 100) + if (lz4_iserror(res) == 0) then + + dOpt%stableDst = 0 + dOpt%skipChecksums = 0 + dOpt%reserved = 0 + + ibytes = input_bytes + dbytes = output_bytes + + res = lz4_decompress(dctxPtr, output_ptr, c_loc(dbytes), & + input_ptr, c_loc(ibytes), c_loc(dOpt)) + + if (lz4_iserror(res) /= 0) then + call print_message(loc, "LZ4 decompression failure.") + status = -1 + end if + + res = lz4_freeDecompressionCtx(dctxPtr) + if (lz4_iserror(res) /= 0) & + call print_message(loc, "Unable to free LZ4 decompression context.") + else + call print_message(loc, "Unable to create LZ4 decompression context.") + status = -1 + end if +#endif /* LZ4 */ +#ifdef LZMA + case(compressor_lzma) + memlim = 16 * MiB + ibytes = 0 + dbytes = 0 + ret = lzma_decompress(c_loc(memlim), 0, c_null_ptr, & + input_ptr, c_loc(ibytes), input_bytes, & + output_ptr, c_loc(dbytes), output_bytes) + if (ret == LZMA_MEMLIMIT_ERROR) then + call print_message(loc, "LZMA memory usage limit was reached.") + write(error_unit,"(a,i0,a)") "The minimum memory limit increased to ", & + memlim / MiB, " MiB." + ibytes = 0 + dbytes = 0 + ret = lzma_decompress(c_loc(memlim), 0, c_null_ptr, & + input_ptr, c_loc(ibytes), input_bytes, & + output_ptr, c_loc(dbytes), output_bytes) + end if + if (ret /= LZMA_OK) then + select case(ret) + case(LZMA_NO_CHECK) + call print_message(loc, "LZMA input stream has no integrity check.") + case(LZMA_UNSUPPORTED_CHECK) + call print_message(loc, "LZMA cannot calculate the integrity check.") + case(LZMA_MEM_ERROR) + call print_message(loc, "LZMA cannot allocate memory.") + case(LZMA_MEMLIMIT_ERROR) + call print_message(loc, "LZMA memory usage limit was reached.") + case(LZMA_FORMAT_ERROR) + call print_message(loc, "LZMA file format not recognized.") + case(LZMA_OPTIONS_ERROR) + call print_message(loc, "Invalid or unsupported LZMA options.") + case(LZMA_DATA_ERROR) + call print_message(loc, "LZMA data is corrupt.") + case(LZMA_BUF_ERROR) + call print_message(loc, "LZMA output buffer was too small.") + case(LZMA_PROG_ERROR) + call print_message(loc, "LZMA programming error.") + case default + call print_message(loc, "Unknown LZMA error.") + end select + status = -1 + end if +#endif /* LZMA */ + case default + call print_message(loc, "Unsupported decompression format.") + status = -1 + end select + +!------------------------------------------------------------------------------- +! + end subroutine decompress +! +!=============================================================================== +! +! subroutine CHECK_ENCODER: +! ------------------------ +! +! Subroutine sets the encoder ID based on the encoder name. +! +! Arguments: +! +! encoder_name - the data encoder name; +! encoder_id - the data encoder id; +! +!=============================================================================== +! + subroutine check_encoder(encoder_name, encoder_id) + + implicit none + + character(len=*) , intent(in ) :: encoder_name + integer , intent( out) :: encoder_id + +!------------------------------------------------------------------------------- +! + select case(trim(adjustl(encoder_name))) + case('shuffle', 'SHUFFLE') + encoder_id = encoder_shuffle + case('bytedelta', 'BYTEDELTA') + encoder_id = encoder_bytedelta + case default + encoder_id = encoder_none + end select + +!------------------------------------------------------------------------------- +! + end subroutine check_encoder +! +!=============================================================================== +! +! function GET_ENCODER_ID: +! ----------------------- +! +! Function returns the encoder ID. +! +! Arguments: +! +! encoder - the encoder name; +! +!=============================================================================== +! + integer function get_encoder_id(encoder) result(encoder_id) + + use helpers, only : print_message + + implicit none + + character(len=*), intent(in) :: encoder + + character(len=*), parameter :: loc = "COMPRESSION::get_encoder_id()" + +!------------------------------------------------------------------------------- +! + select case(trim(adjustl(encoder))) + case('shuffle', 'SHUFFLE') + encoder_id = encoder_shuffle + case('bytedelta', 'BYTEDELTA') + encoder_id = encoder_bytedelta + case("none") + encoder_id = encoder_none + case default + encoder_id = encoder_unkn + call print_message(loc, "Unsupported encoder '" // trim(encoder) // "'.") + end select + + return + +!------------------------------------------------------------------------------- +! + end function get_encoder_id +! +!=============================================================================== +! +! function GET_ENCODER_NAME: +! ------------------------- +! +! Function returns the name of the data encoder. +! +! Arguments: +! +! encoder_id - the data encoder ID; +! +!=============================================================================== +! + character(len=16) function get_encoder_name(encoder_id) + + implicit none + + integer, intent(in) :: encoder_id + +!------------------------------------------------------------------------------- +! + select case(encoder_id) + case(encoder_shuffle) + get_encoder_name = 'shuffle' + case(encoder_bytedelta) + get_encoder_name = 'bytedelta' + case default + get_encoder_name = 'none' + end select + return + +!------------------------------------------------------------------------------- +! + end function get_encoder_name +! +!=============================================================================== +! +! function IS_ENCODER_ON: +! ---------------------- +! +! The function determines if any data encoding is used. +! +! Arguments: +! +! encoder_id - the data encoder ID; +! +!=============================================================================== +! + logical function is_encoder_on(encoder_id) + + implicit none + + integer, intent(in) :: encoder_id + +!------------------------------------------------------------------------------- +! + is_encoder_on = encoder_id /= encoder_none + return + +!------------------------------------------------------------------------------- +! + end function is_encoder_on +! +!=============================================================================== +! ! subroutine ENCODE: ! ----------------- ! @@ -349,21 +913,21 @@ module compression ! ! Arguments: ! -! filter_type - the filter type to apply, 1 - shuffle, 2 - bytedelta; -! item_size - the size of each item in bytes; -! bytes - the length of the input data; -! input_ptr - the pointer to the input data; -! output - the output where the encoded data are written; +! encoder_id - the data encoder ID; +! item_size - the size of each item in bytes; +! bytes - the length of the input data; +! input_ptr - the pointer to the input data; +! output - the output where the encoded data are written; ! !=============================================================================== ! - subroutine encode(filter_type, item_size, bytes, input_ptr, output) + subroutine encode(encoder_id, item_size, bytes, input_ptr, output) use iso_c_binding, only : c_ptr, c_f_pointer implicit none - integer(kind=1) , intent(in ) :: filter_type + integer , intent(in ) :: encoder_id integer(kind=4) , intent(in ) :: item_size integer(kind=8) , intent(in ) :: bytes type(c_ptr) , intent(in ) :: input_ptr @@ -377,8 +941,8 @@ module compression ! call c_f_pointer(input_ptr, input, [ bytes ]) - select case(filter_type) - case(1) + select case(encoder_id) + case(encoder_shuffle) item_count = bytes / item_size i = 1 @@ -390,7 +954,7 @@ module compression j = j + item_count end do - case(2) + case(encoder_bytedelta) item_count = bytes / item_size i = 1 @@ -413,6 +977,93 @@ module compression !------------------------------------------------------------------------------- ! end subroutine encode +! +!=============================================================================== +! +! subroutine DECODE: +! ----------------- +! +! This subroutine is responsible for decoding the input buffer using +! the specified data encoder. +! +! Arguments: +! +! encoder_id - an identifier for the data encoder to be used; +! item_size - the size of an individual data item in bytes; +! bytes - the total size of the input data in bytes; +! input_ptr - a pointer to the start of the input data; +! output - the destination where the decoded data will be written; +! +!=============================================================================== +! + subroutine decode(encoder_id, item_size, bytes, input_ptr, output) + + use helpers, only : print_message + + implicit none + + integer , intent(in ) :: encoder_id + integer(kind=4) , intent(in ) :: item_size + integer(kind=8) , intent(in ) :: bytes + type(c_ptr) , intent(in ) :: input_ptr + integer(kind=1), dimension(bytes), intent(inout) :: output + + character(len=*), parameter :: loc = "COMPRESSION::decode()" + + integer(kind=1), dimension(:), pointer :: input + integer(kind=1), dimension(:), allocatable :: buffer + + integer(kind=8) :: i, j, m, n, item_count + +!------------------------------------------------------------------------------- +! + call c_f_pointer(input_ptr, input, [ bytes ]) + + select case(encoder_id) + case(encoder_none) + output(:) = input(:) + + case(encoder_shuffle) + item_count = bytes / item_size + + i = 1 + j = item_count + do m = 1, item_size + output(m:bytes:item_size) = input(i:j) + + i = j + 1 + j = j + item_count + end do + + case(encoder_bytedelta) + item_count = bytes / item_size + + allocate(buffer(bytes)) + + i = 1 + j = item_count + do m = 1, item_size + buffer(i) = input(i) + do n = i + 1, j + buffer(n) = input(n) + buffer(n-1) + end do + + output(m:bytes:item_size) = buffer(i:j) + + i = j + 1 + j = j + item_count + end do + + deallocate(buffer) + + case default + call print_message(loc, "Unsupported encoder.") + + end select + +!------------------------------------------------------------------------------- +! + end subroutine decode !=============================================================================== ! diff --git a/sources/io.F90 b/sources/io.F90 index 0ee82c4..4c9d78f 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -43,12 +43,6 @@ module io module procedure read_snapshot_parameter_integer module procedure read_snapshot_parameter_double end interface - interface write_attribute_xml - module procedure write_attribute_xml_string - module procedure write_attribute_xml_integer - module procedure write_attribute_xml_double - module procedure write_attribute_xml_file - end interface #ifdef HDF5 interface read_snapshot_parameter_h5 module procedure read_snapshot_parameter_string_h5 @@ -115,18 +109,17 @@ module io ! the compression format and level of the XML+binary files ! - character(len=255), save :: cformat = "none" ! compression format - integer , save :: clevel = 3 ! compression level + integer :: snapshot_compressor = 0, & + compression_level = -22 -! data filter applied before the compression: -! (0 - no filter, 1 - shuffle, 2 - bytedelta) +! data encoder applied before the compression ! - integer(kind=1) :: data_filter = 0 + integer :: snapshot_encoder = 0 ! the type of digest to use and its length ! - integer, save :: hash_type = 0 - integer, save :: hash_length = 0 + integer :: hash_type = 0, & + hash_size = 0 #ifdef HDF5 ! supported compression types @@ -190,7 +183,8 @@ module io ! subroutine initialize_io(verbose, status) - use compression, only : set_compression, get_compression, compression_none + use compression, only : check_compressor, is_compressor_on, & + check_encoder, get_compressor_name use hash , only : hash_info use helpers , only : print_message #ifdef HDF5 @@ -209,7 +203,7 @@ module io character(len=255) :: precise = "off" character(len=255) :: ghosts = "on" character(len=255) :: xdmf = "off" - character(len=8) :: dtype = "xxh64" + character(len=8) :: htype = "xxh64" #ifdef HDF5 integer(hsize_t) :: cd_nelmts = 6 integer, dimension(6) :: cd_values = 0 @@ -286,24 +280,19 @@ module io nrest = nrest - 1 end if - call get_parameter("compression_format", cformat) - call get_parameter("compression_level" , clevel) - call set_compression(cformat, clevel) + string = "none" + call get_parameter("compression_format", string) + call get_parameter("compression_level" , compression_level) + call check_compressor(string, snapshot_compressor, & + compression_level) string = "none" - call get_parameter("data_filter", string) - select case(string) - case('shuffle', 'SHUFFLE') - data_filter = 1 - case('bytedelta', 'BYTEDELTA') - data_filter = 2 - case default - data_filter = 0 - end select - if (get_compression() == compression_none) data_filter = 0 + if (is_compressor_on(snapshot_compressor)) & + call get_parameter("data_encoder", string) + call check_encoder(string, snapshot_encoder) - call get_parameter("digest_type", dtype) - call hash_info(dtype, hash_type, hash_length) + call get_parameter("digest_type", htype) + call hash_info(htype, hash_type, hash_size) if (status == 0) then @@ -478,8 +467,10 @@ module io ! subroutine print_io(verbose) - use hash , only : hash_name - use helpers, only : print_section, print_parameter + use compression, only : get_compressor_name, get_encoder_name, & + is_compressor_on + use hash , only : hash_name + use helpers , only : print_section, print_parameter implicit none @@ -508,16 +499,14 @@ module io case default call print_parameter(verbose, "restart snapshot format", "XML+binary") call print_parameter(verbose, "digest type", hash_name(hash_type)) - call print_parameter(verbose, "compression format", cformat) - call print_parameter(verbose, "compression level", clevel) - select case(data_filter) - case(1) - call print_parameter(verbose, "data filter", "shuffle") - case(2) - call print_parameter(verbose, "data filter", "bytedelta") - case default - call print_parameter(verbose, "data filter", "none") - end select + if (is_compressor_on(snapshot_compressor)) then + call print_parameter(verbose, "compression format", & + get_compressor_name(snapshot_compressor)) + call print_parameter(verbose, "compression level", & + compression_level) + call print_parameter(verbose, "data encoder", & + get_encoder_name(snapshot_encoder)) + end if end select call print_parameter(verbose, "precise snapshot intervals", & precise_snapshots, "on") @@ -1104,12 +1093,14 @@ module io use blocks , only : metablock_set_leaf use blocks , only : change_blocks_process use coordinates , only : nn => bcells, ncells, nghosts - use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax + use coordinates , only : xmin, xmax, ymin, ymax +#if NDIMS == 3 + use coordinates , only : zmin, zmax +#endif /* NDIMS == 3 */ use equations , only : cmax, cmax2, cglm use evolution , only : step, time, dt, dth, dte use evolution , only : niterations, nrejections, errs use forcing , only : nmodes, fcoefs, einj - use hash , only : hash_info, check_digest, digest_integer use helpers , only : print_message use iso_c_binding, only : c_loc #ifdef MPI @@ -1117,33 +1108,30 @@ module io #endif /* MPI */ use mpitools , only : nprocs, nproc use random , only : gentype, set_seeds + use XML , only : XMLNode, XMLParseFile, XMLFreeTree, & + XMLGetElementValue implicit none integer, intent(out) :: status + type(XMLNode), pointer :: xml_ptr + logical :: test - character(len=255) :: dname, fname, line, sname, svalue + character(len=256) :: snapshot_path, file_path + character(len= 16) :: aname integer :: il, iu, nl, nx, nm, nd, nv, i, j, l, n, p, nu, nr #if NDIMS == 3 integer :: k #endif /* NDIMS == 3 */ integer(kind=4) :: lndims, lnprocs, lnproc, lmblocks, lnleafs, llast_id - integer(kind=4) :: ldblocks, lncells, lnghosts, lnseeds, lnmodes + integer(kind=4) :: lncells, lnghosts, lnseeds, lnmodes + integer(kind=8) :: bytes real(kind=8) :: deinj type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata - integer :: dtype, dlen - - integer(kind=4) :: lun = 104 - integer(kind=8) :: bytes, pbytes, ubytes - - integer(kind=8) :: hfield, hchild, hface, hedge, hcorner, hbound - integer(kind=8) :: hids, hseed, hforce - - integer(kind=8), dimension(:) , allocatable :: hprim, hcons integer(kind=4), dimension(:) , allocatable, target :: ids integer(kind=4), dimension(:,:) , allocatable, target :: fields integer(kind=4), dimension(:,:) , allocatable, target :: children @@ -1168,141 +1156,65 @@ module io ! status = 0 - write(dname, "(a,'restart-',i5.5)") trim(respath), nrest + write(snapshot_path, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER - inquire(directory=dname, exist=test) + inquire(directory=snapshot_path, exist=test) #else /* __INTEL_COMPILER */ - inquire(file=dname, exist=test) + inquire(file=snapshot_path, exist=test) #endif /* __INTEL_COMPILER */ if (.not. test) then - call print_message(loc, trim(dname) // " does not exist!") + call print_message(loc, trim(snapshot_path) // " does not exist!") status = 121 return end if - dname = trim(dname) // "/" + snapshot_path = trim(snapshot_path) // "/" + file_path = trim(snapshot_path) // "metadata.xml" - write(fname,"(a,'metadata.xml')") trim(dname) - inquire(file=fname, exist=test) + inquire(file=file_path, exist=test) if (.not. test) then - call print_message(loc, trim(fname) // " does not exist!") + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") status = 121 return end if - open(newunit=lun, file=fname, status='old') -10 read(lun, fmt="(a)", end=20) line - if (index(line, ' 0) then - il = index(line, 'name="') - if (il > 0) then - il = il + 6 - iu = index(line(il:), '"') + il - 2 - write(sname,*) line(il:iu) - il = index(line, '>') + 1 - iu = index(line, '<', back=.true.) - 1 - write(svalue,*) line(il:iu) + call XMLParseFile(file_path, xml_ptr, status) - select case(trim(adjustl(sname))) - case('ndims') - read(svalue, fmt=*) lndims - case('nprocs') - read(svalue, fmt=*) lnprocs - case('nproc') - read(svalue, fmt=*) lnproc - case('mblocks') - read(svalue, fmt=*) lmblocks - case('dblocks') - read(svalue, fmt=*) ldblocks - case('nleafs') - read(svalue, fmt=*) lnleafs - case('last_id') - read(svalue, fmt=*) llast_id - case('ncells') - read(svalue, fmt=*) lncells - case('nghosts') - read(svalue, fmt=*) lnghosts - case('nseeds') - read(svalue, fmt=*) lnseeds - case('step') - read(svalue, fmt=*) step - case('isnap') - read(svalue, fmt=*) isnap - case('nvars') - read(svalue, fmt=*) nv - case('nmodes') - read(svalue, fmt=*) lnmodes - case('xmin') - read(svalue, fmt=*) xmin - case('xmax') - read(svalue, fmt=*) xmax - case('ymin') - read(svalue, fmt=*) ymin - case('ymax') - read(svalue, fmt=*) ymax - case('zmin') - read(svalue, fmt=*) zmin - case('zmax') - read(svalue, fmt=*) zmax - case('time') - read(svalue, fmt=*) time - case('dt') - read(svalue, fmt=*) dt - case('dth') - read(svalue, fmt=*) dth - case('dte') - read(svalue, fmt=*) dte - case('cmax') - read(svalue, fmt=*) cmax - cmax2 = cmax * cmax - case('cglm') - read(svalue, fmt=*) cglm - case('niterations') - read(svalue, fmt=*) niterations - case('nrejections') - read(svalue, fmt=*) nrejections - case('errs(1)') - read(svalue, fmt=*) errs(1) - case('errs(2)') - read(svalue, fmt=*) errs(2) - case('errs(3)') - read(svalue, fmt=*) errs(3) - case('fields') - il = index(line, 'digest_type="') + 13 - iu = index(line(il:), '"') + il - 2 - call hash_info(line(il:iu), dtype, dlen) + call XMLGetElementValue(xml_ptr, 'Parallelization', 'nprocs' , lnprocs) + call XMLGetElementValue(xml_ptr, 'Parallelization', 'nproc' , lnproc) + call XMLGetElementValue(xml_ptr, 'Physics' , 'nvars' , nv) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'ndims' , lndims) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmin' , xmin) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmax' , xmax) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymin' , ymin) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymax' , ymax) +#if NDIMS == 3 + call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmin' , zmin) + call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmax' , zmax) +#endif /* NDIMS == 3 */ + call XMLGetElementValue(xml_ptr, 'Mesh' , 'ncells' , lncells) + call XMLGetElementValue(xml_ptr, 'Mesh' , 'nghosts' , lnghosts) + call XMLGetElementValue(xml_ptr, 'Mesh' , 'mblocks' , lmblocks) + call XMLGetElementValue(xml_ptr, 'Mesh' , 'nleafs' , lnleafs) + call XMLGetElementValue(xml_ptr, 'Mesh' , 'last_id' , llast_id) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'step' , step) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'time' , time) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'dt' , dt) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'dth' , dth) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'dte' , dte) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'cmax' , cmax) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'cglm' , cglm) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'niterations', niterations) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'nrejections', nrejections) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(1)' , errs(1)) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(2)' , errs(2)) + call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(3)' , errs(3)) + call XMLGetElementValue(xml_ptr, 'Forcing' , 'nmodes' , lnmodes) + call XMLGetElementValue(xml_ptr, 'Random' , 'nseeds' , lnseeds) + call XMLGetElementValue(xml_ptr, 'Snapshots' , 'isnap' , isnap) - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hfield) - case('children') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hchild) - case('faces') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hface) - case('edges') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hedge) - case('corners') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hcorner) - case('bounds') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hbound) - case('forcing') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hforce) - end select - end if - end if - go to 10 -20 close(lun) + cmax2 = cmax * cmax if (lndims /= NDIMS) then call print_message(loc, "The number of dimensions does not match!") @@ -1338,44 +1250,31 @@ module io if (status == 0) then - write(fname,"(a,'metablock_fields.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) fields - close(lun) bytes = size(fields, kind=8) * kind(fields) - call check_digest(loc, fname, c_loc(fields), bytes, hfield, dtype) - write(fname,"(a,'metablock_children.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) children - close(lun) + call read_binary_xml(snapshot_path, 'fields' , c_loc(fields), & + bytes, xml_ptr, status) + bytes = size(children, kind=8) * kind(children) - call check_digest(loc, fname, c_loc(children), bytes, hchild, dtype) + call read_binary_xml(snapshot_path, 'children', c_loc(children), & + bytes, xml_ptr, status) + #if NDIMS == 3 - write(fname,"(a,'metablock_faces.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) faces - close(lun) bytes = size(faces, kind=8) * kind(faces) - call check_digest(loc, fname, c_loc(faces), bytes, hface, dtype) + call read_binary_xml(snapshot_path, 'faces' , c_loc(faces), & + bytes, xml_ptr, status) + #endif /* NDIMS == 3 */ - write(fname,"(a,'metablock_edges.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) edges - close(lun) bytes = size(edges, kind=8) * kind(edges) - call check_digest(loc, fname, c_loc(edges), bytes, hedge, dtype) - write(fname,"(a,'metablock_corners.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) corners - close(lun) + call read_binary_xml(snapshot_path, 'edges' , c_loc(edges), & + bytes, xml_ptr, status) + bytes = size(corners, kind=8) * kind(corners) - call check_digest(loc, fname, c_loc(corners), bytes, hcorner, dtype) - write(fname,"(a,'metablock_bounds.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) bounds - close(lun) + call read_binary_xml(snapshot_path, 'corners' , c_loc(corners), & + bytes, xml_ptr, status) + bytes = size(bounds, kind=8) * kind(bounds) - call check_digest(loc, fname, c_loc(bounds), bytes, hbound, dtype) + call read_binary_xml(snapshot_path, 'bounds' , c_loc(bounds), & + bytes, xml_ptr, status) l = 0 pmeta => list_meta @@ -1459,14 +1358,14 @@ module io if (lnmodes == nmodes) then if (lnmodes > 0) then + allocate(lfcoefs(lnmodes,lndims), stat=status) if (status == 0) then - write(fname,"(a,'forcing_coefficients.bin')") trim(dname) - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) lfcoefs - close(lun) + bytes = size(lfcoefs, kind=8) * kind(lfcoefs) * 2 - call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype) + call read_binary_xml(snapshot_path, 'forcing', c_loc(lfcoefs), & + bytes, xml_ptr, status) + fcoefs = lfcoefs deallocate(lfcoefs, stat=status) if (status /= 0) & @@ -1481,6 +1380,10 @@ module io call print_message(loc, "The number of forcing modes does not match!") end if +! release the XML tree for 'metadata.xml' file +! + call XMLFreeTree(xml_ptr) + if (nprocs >= lnprocs) then ! spread the restart snapshots reading across new processes so we do not @@ -1502,64 +1405,20 @@ module io if (nl >= 0) then - write(fname,sfmt) trim(dname), "datablocks", nl, "xml" - inquire(file=fname, exist=test) + write(file_path, sfmt) trim(snapshot_path), "datablocks", nl, "xml" + inquire(file=file_path, exist=test) if (.not. test) then - write(*,*) trim(fname) // " does not exist!" + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") status = 121 return end if - open(newunit=lun, file=fname, status='old') -30 read(lun, fmt="(a)", end=40) line - if (index(line, ' 0) then - il = index(line, 'name="') - if (il > 0) then - il = il + 6 - iu = index(line(il:), '"') + il - 2 - write(sname,*) line(il:iu) - il = index(line, '>') + 1 - iu = index(line, '<', back=.true.) - 1 - write(svalue,*) line(il:iu) + call XMLParseFile(file_path, xml_ptr, status) - select case(trim(adjustl(sname))) - case('dblocks') - read(svalue, fmt=*) nd - if (nd > 0) then - allocate(hprim(nd), hcons(nd), stat=status) - if (status /= 0) & - call print_message(loc, & - "Could not allocate space for hashes!") - end if - case('nregs') - read(svalue, fmt=*) nr - case('einj') - read(svalue, fmt=*) einj - case('ids') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hids) - case('seeds') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hseed) - end select - if (index(sname, 'prim') > 0) then - read(sname(7:), fmt=*) l - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hprim(l)) - end if - if (index(sname, 'cons') > 0) then - read(sname(7:), fmt=*) l - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hcons(l)) - end if - end if - end if - go to 30 -40 close(lun) + call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd) + call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr) + call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , einj) nm = lncells + 2 * lnghosts if (lnghosts >= nghosts) then @@ -1580,27 +1439,18 @@ module io if (status == 0) then - write(fname,sfmt) trim(dname), "datablock_ids", nl, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) ids - close(lun) bytes = size(ids, kind=8) * kind(ids) - call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype) - - ubytes = size(array, kind=8) * kind(array) - pbytes = ubytes / nr + call read_binary_xml(snapshot_path, 'ids', c_loc(ids), & + bytes, xml_ptr, status) + bytes = size(array, kind=8) * kind(array) / nr do l = 1, nd call append_datablock(pdata, status) call link_blocks(block_array(ids(l))%ptr, pdata) - write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nl, l - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) array(:,:,:,:,1) - close(lun) - call check_digest(loc, fname, c_loc(array), & - pbytes, hprim(l), dtype) + write(aname, "('prim_',i6.6)") l + call read_binary_xml(snapshot_path, aname, c_loc(array), & + bytes, xml_ptr, status) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1616,13 +1466,9 @@ module io #endif /* NDIMS == 3 */ end if - write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nl, l - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) array - close(lun) - call check_digest(loc, fname, c_loc(array), & - ubytes, hcons(l), dtype) + write(aname, "('cons_',i6.6)") l + call read_binary_xml(snapshot_path, aname, c_loc(array), & + bytes * nr, xml_ptr, status) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1640,7 +1486,7 @@ module io end if end do - deallocate(ids, array, hprim, hcons, stat=status) + deallocate(ids, array, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of datablocks!") else @@ -1652,12 +1498,9 @@ module io if (status == 0) then - write(fname,sfmt) trim(dname), "random_seeds", nl, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) seeds - close(lun) bytes = size(seeds, kind=8) * kind(seeds) - call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) + call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & + bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) deallocate(seeds, stat=status) @@ -1667,40 +1510,11 @@ module io call print_message(loc, "Could not allocate space for seeds!") end if + call XMLFreeTree(xml_ptr) + else ! nl < 0 - write(fname,sfmt) trim(dname), "datablocks", 0, "xml" - inquire(file=fname, exist=test) - if (.not. test) then - write(*,*) trim(fname) // " does not exist!" - status = 121 - return - end if - - open(newunit=lun, file=fname, status='old') -50 read(lun, fmt="(a)", end=60) line - if (index(line, ' 0) then - il = index(line, 'name="') - if (il > 0) then - il = il + 6 - iu = index(line(il:), '"') + il - 2 - write(sname,*) line(il:iu) - il = index(line, '>') + 1 - iu = index(line, '<', back=.true.) - 1 - write(svalue,*) line(il:iu) - - select case(trim(adjustl(sname))) - case('seeds') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hseed) - end select - end if - end if - go to 50 -60 close(lun) - -! restore PRNG seeds for remaining processes +! restore PRNG seeds for the remaining processes ! if (trim(gentype) == "same") then @@ -1708,14 +1522,24 @@ module io if (status == 0) then - write(fname,sfmt) trim(dname), "random_seeds", 0, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) seeds - close(lun) + write(file_path, sfmt) trim(snapshot_path), "datablocks", 0, "xml" + inquire(file=file_path, exist=test) + if (.not. test) then + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") + status = 121 + return + end if + + call XMLParseFile(file_path, xml_ptr, status) + bytes = size(seeds, kind=8) * kind(seeds) - call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) + call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & + bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) + call XMLFreeTree(xml_ptr) + deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of seeds!") @@ -1753,66 +1577,21 @@ module io do n = nl, nu - write(fname,sfmt) trim(dname), "datablocks", n, "xml" - inquire(file=fname, exist=test) + write(file_path, sfmt) trim(snapshot_path), "datablocks", n, "xml" + inquire(file=file_path, exist=test) if (.not. test) then - write(*,*) trim(fname) // " does not exist!" + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") status = 121 return end if -! read attributes from the metadata file -! - open(newunit=lun, file=fname, status='old') -70 read(lun, fmt="(a)", end=80) line - if (index(line, ' 0) then - il = index(line, 'name="') - if (il > 0) then - il = il + 6 - iu = index(line(il:), '"') + il - 2 - write(sname,*) line(il:iu) - il = index(line, '>') + 1 - iu = index(line, '<', back=.true.) - 1 - write(svalue,*) line(il:iu) + call XMLParseFile(file_path, xml_ptr, status) + + call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd) + call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr) + call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , deinj) - select case(trim(adjustl(sname))) - case('dblocks') - read(svalue, fmt=*) nd - if (nd > 0) then - allocate(hprim(nd), hcons(nd), stat=status) - if (status /= 0) & - call print_message(loc, & - "Could not allocate space for hashes!") - end if - case('nregs') - read(svalue, fmt=*) nr - case('einj') - read(svalue, fmt=*) deinj - case('ids') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hids) - case('seeds') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hseed) - end select - if (index(sname, 'prim') > 0) then - read(sname(7:), fmt=*) l - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hprim(l)) - end if - if (index(sname, 'cons') > 0) then - read(sname(7:), fmt=*) l - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - call digest_integer(line(il:iu), hcons(l)) - end if - end if - end if - go to 70 -80 close(lun) einj = einj + deinj nm = lncells + 2 * lnghosts @@ -1834,27 +1613,18 @@ module io if (status == 0) then - write(fname,sfmt) trim(dname), "datablock_ids", n, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) ids - close(lun) bytes = size(ids, kind=8) * kind(ids) - call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype) - - ubytes = size(array, kind=8) * kind(array) - pbytes = ubytes / nr + call read_binary_xml(snapshot_path, 'ids', c_loc(ids), & + bytes, xml_ptr, status) + bytes = size(array, kind=8) * kind(array) / nr do l = 1, nd call append_datablock(pdata, status) call link_blocks(block_array(ids(l))%ptr, pdata) - write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") & - trim(dname), n, l - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) array(:,:,:,:,1) - close(lun) - call check_digest(loc, fname, c_loc(array), & - pbytes, hprim(l), dtype) + write(aname, "('prim_',i6.6)") l + call read_binary_xml(snapshot_path, aname, c_loc(array), & + bytes, xml_ptr, status) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1870,13 +1640,9 @@ module io #endif /* NDIMS == 3 */ end if - write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") & - trim(dname), n, l - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) array - close(lun) - call check_digest(loc, fname, c_loc(array), & - ubytes, hcons(l), dtype) + write(aname, "('cons_',i6.6)") l + call read_binary_xml(snapshot_path, aname, c_loc(array), & + bytes * nr, xml_ptr, status) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1894,28 +1660,41 @@ module io end if end do - deallocate(ids, array, hprim, hcons, stat=status) + deallocate(ids, array, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of datablocks!") else call print_message(loc, "Could not allocate space for datablocks!") end if + end if + call XMLFreeTree(xml_ptr) + end do ! n = nl, nu allocate(seeds(4,lnseeds), stat=status) if (status == 0) then - write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) seeds - close(lun) + write(file_path, sfmt) trim(snapshot_path), "datablocks", nproc, "xml" + inquire(file=file_path, exist=test) + if (.not. test) then + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") + status = 121 + return + end if + + call XMLParseFile(file_path, xml_ptr, status) + bytes = size(seeds, kind=8) * kind(seeds) - call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) + call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & + bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) + call XMLFreeTree(xml_ptr) + deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of seeds!") @@ -1974,23 +1753,29 @@ module io use mpitools , only : nprocs, nproc use parameters , only : get_parameter_file use random , only : gentype, nseeds, get_seeds + use XML , only : XMLNode, XMLAddElement, & + XMLInitTree, XMLFreeTree, XMLSaveTree implicit none - character(len=*), intent(in) :: problem - integer , intent(in) :: nrun - integer , intent(out) :: status + character(len=*), intent(in ) :: problem + integer , intent(in ) :: nrun + integer , intent( out) :: status - logical :: test - character(len=64) :: dname, fname, aname - integer(kind=8) :: digest, bytes - integer(kind=4) :: lun = 103 - integer :: dtype, dlen - integer :: nd, nl, nm, nx, i, j, l, n, p + character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()" + + logical :: test + character(len=128) :: str + integer(kind=8) :: bytes + integer :: htype, hsize + integer :: nd, nl, nm, nx, i, j, l, n, p #if NDIMS == 3 - integer :: k + integer :: k #endif /* NDIMS == 3 */ + character(len=:), allocatable :: rpath, cmd, aname + + type(XMLNode) , pointer :: xml_ptr type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata @@ -2009,120 +1794,99 @@ module io integer(kind=8), dimension(:,:) , allocatable, target :: seeds real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds - character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()" - character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" - !------------------------------------------------------------------------------- ! status = 0 - call hash_info("xxh64", dtype, dlen) + call hash_info("xxh64", htype, hsize) - write(dname, "('restart-',i5.5)") nrun + write(str, "('restart-',i5.5,'/')") nrun + rpath = trim(str) + cmd = "mkdir -p " // trim(rpath) #ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) + inquire(directory=rpath, exist=test) do while(.not. test) - if (.not. test) call execute_command_line("mkdir -p " // trim(dname)) - inquire(directory = dname, exist = test) + if (.not. test) call execute_command_line(cmd) + inquire(directory=rpath, exist=test) end do #else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) + inquire(file=rpath, exist=test) do while(.not. test) - if (.not. test) call execute_command_line("mkdir -p " // trim(dname)) - inquire(file = dname, exist = test) + if (.not. test) call execute_command_line(cmd) + inquire(file=rpath, exist=test) end do #endif /* __INTEL_COMPILER */ - dname = trim(dname) // "/" nx = get_last_id() nm = get_mblocks() nd = get_dblocks() nl = get_nleafs() + aname = '' + if (nproc == 0) then - call get_parameter_file(fname, status) + call get_parameter_file(str, status) + cmd = "cp -a " // trim(str) // " " // rpath if (status == 0) then - call execute_command_line("cp -a " // trim(fname) // " " // trim(dname)) + call execute_command_line(cmd) else call print_message(loc, "Cannot get the location of parameter file!") return end if - write(fname,"(a,'metadata.xml')") trim(dname) - open(newunit = lun, file = fname, status = 'replace') - write(lun,"(a)") "" - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "problem" , problem) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "nprocs" , nprocs) - call write_attribute_xml(lun, "nproc" , nproc) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "eqsys" , eqsys) - call write_attribute_xml(lun, "eos" , eos) - call write_attribute_xml(lun, "nvars" , nv) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "ndims" , NDIMS) - call write_attribute_xml(lun, "xblocks" , bdims(1)) - call write_attribute_xml(lun, "yblocks" , bdims(2)) + call XMLInitTree(xml_ptr) + call XMLAddElement(xml_ptr, "Problem" , "problem" , problem) + call XMLAddElement(xml_ptr, "Parallelization", "nprocs" , nprocs) + call XMLAddElement(xml_ptr, "Parallelization", "nproc" , nproc ) + call XMLAddElement(xml_ptr, "Physics" , "eqsys" , eqsys ) + call XMLAddElement(xml_ptr, "Physics" , "eos" , eos ) + call XMLAddElement(xml_ptr, "Physics" , "nvars" , nv ) + call XMLAddElement(xml_ptr, "Geometry" , "ndims" , NDIMS ) + call XMLAddElement(xml_ptr, "Geometry" , "xblocks" , bdims(1)) + call XMLAddElement(xml_ptr, "Geometry" , "yblocks" , bdims(2)) #if NDIMS == 3 - call write_attribute_xml(lun, "zblocks" , bdims(3)) + call XMLAddElement(xml_ptr, "Geometry" , "zblocks" , bdims(3)) #endif /* NDIMS */ - call write_attribute_xml(lun, "xmin" , xmin) - call write_attribute_xml(lun, "xmax" , xmax) - call write_attribute_xml(lun, "ymin" , ymin) - call write_attribute_xml(lun, "ymax" , ymax) + call XMLAddElement(xml_ptr, "Geometry" , "xmin" , xmin) + call XMLAddElement(xml_ptr, "Geometry" , "xmax" , xmax) + call XMLAddElement(xml_ptr, "Geometry" , "ymin" , ymin) + call XMLAddElement(xml_ptr, "Geometry" , "ymax" , ymax) #if NDIMS == 3 - call write_attribute_xml(lun, "zmin" , zmin) - call write_attribute_xml(lun, "zmax" , zmax) + call XMLAddElement(xml_ptr, "Geometry" , "zmin" , zmin) + call XMLAddElement(xml_ptr, "Geometry" , "zmax" , zmax) #endif /* NDIMS */ - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "minlev" , minlev) - call write_attribute_xml(lun, "maxlev" , maxlev) - call write_attribute_xml(lun, "ncells" , ncells) - call write_attribute_xml(lun, "nghosts" , nghosts) - call write_attribute_xml(lun, "bcells" , nn) - call write_attribute_xml(lun, "nchildren", nc) - call write_attribute_xml(lun, "mblocks" , nm) - call write_attribute_xml(lun, "nleafs" , nl) - call write_attribute_xml(lun, "last_id" , nx) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "step" , step) - call write_attribute_xml(lun, "time" , time) - call write_attribute_xml(lun, "dt" , dt) - call write_attribute_xml(lun, "dth" , dth) - call write_attribute_xml(lun, "dte" , dte) - call write_attribute_xml(lun, "cfl" , cfl) - call write_attribute_xml(lun, "cmax" , cmax) - call write_attribute_xml(lun, "cglm" , cglm) - call write_attribute_xml(lun, "glm_alpha", glm_alpha) - call write_attribute_xml(lun, "absolute_tolerance", atol) - call write_attribute_xml(lun, "relative_tolerance", rtol) - call write_attribute_xml(lun, "maximum_rejections", mrej) - call write_attribute_xml(lun, "niterations", niterations) - call write_attribute_xml(lun, "nrejections", nrejections) - call write_attribute_xml(lun, "errs(1)", errs(1)) - call write_attribute_xml(lun, "errs(2)", errs(2)) - call write_attribute_xml(lun, "errs(3)", errs(3)) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "nmodes" , nmodes) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "gentype" , gentype) - call write_attribute_xml(lun, "nseeds" , nseeds) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "isnap" , isnap) - write(lun,"(a)") '' - write(lun,"(a)") '' + call XMLAddElement(xml_ptr, "Mesh" , "minlev" , minlev) + call XMLAddElement(xml_ptr, "Mesh" , "maxlev" , maxlev) + call XMLAddElement(xml_ptr, "Mesh" , "ncells" , ncells) + call XMLAddElement(xml_ptr, "Mesh" , "nghosts" , nghosts) + call XMLAddElement(xml_ptr, "Mesh" , "bcells" , nn) + call XMLAddElement(xml_ptr, "Mesh" , "nchildren" , nc) + call XMLAddElement(xml_ptr, "Mesh" , "mblocks" , nm) + call XMLAddElement(xml_ptr, "Mesh" , "nleafs" , nl) + call XMLAddElement(xml_ptr, "Mesh" , "last_id" , nx) + call XMLAddElement(xml_ptr, "Evolution", "step" , step) + call XMLAddElement(xml_ptr, "Evolution", "time" , time) + call XMLAddElement(xml_ptr, "Evolution", "dt" , dt) + call XMLAddElement(xml_ptr, "Evolution", "dth" , dth) + call XMLAddElement(xml_ptr, "Evolution", "dte" , dte) + call XMLAddElement(xml_ptr, "Evolution", "cfl" , cfl) + call XMLAddElement(xml_ptr, "Evolution", "cmax" , cmax) + call XMLAddElement(xml_ptr, "Evolution", "cglm" , cglm) + call XMLAddElement(xml_ptr, "Evolution", "glm_alpha" , glm_alpha) + call XMLAddElement(xml_ptr, "Evolution", "absolute_tolerance", atol) + call XMLAddElement(xml_ptr, "Evolution", "relative_tolerance", rtol) + call XMLAddElement(xml_ptr, "Evolution", "maximum_rejections", mrej) + call XMLAddElement(xml_ptr, "Evolution", "niterations" , niterations) + call XMLAddElement(xml_ptr, "Evolution", "nrejections" , nrejections) + call XMLAddElement(xml_ptr, "Evolution", "errs(1)" , errs(1)) + call XMLAddElement(xml_ptr, "Evolution", "errs(2)" , errs(2)) + call XMLAddElement(xml_ptr, "Evolution", "errs(3)" , errs(3)) + call XMLAddElement(xml_ptr, "Forcing" , "nmodes" , nmodes) + call XMLAddElement(xml_ptr, "Random" , "gentype" , gentype) + call XMLAddElement(xml_ptr, "Random" , "nseeds" , nseeds) + call XMLAddElement(xml_ptr, "Snapshots", "isnap" , isnap) allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), & #if NDIMS == 3 @@ -2212,57 +1976,66 @@ module io pmeta => pmeta%next end do - write(fname,"(a,'.bin')") "metablock_fields" bytes = size(fields, kind=8) * kind(fields) - call write_binary_xml(dname, fname, c_loc(fields), bytes, & - kind(fields), dtype, digest) - call write_attribute_xml(lun, "fields", fname, 'int32', & - shape(fields), bytes, dtype, digest) + call write_binary_xml(rpath, "fields", "metablock_fields", & + c_loc(fields), bytes, "int32", shape(fields), & + htype, snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock fields!") - write(fname,"(a,'.bin')") "metablock_children" bytes = size(children, kind=8) * kind(children) - call write_binary_xml(dname, fname, c_loc(children), bytes, & - kind(children), dtype, digest) - call write_attribute_xml(lun, "children", fname, 'int32', & - shape(children), bytes, dtype, digest) + call write_binary_xml(rpath, "children", "metablock_children", & + c_loc(children), bytes, "int32", shape(children),& + htype, snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock children!") #if NDIMS == 3 - write(fname,"(a,'.bin')") "metablock_faces" bytes = size(faces, kind=8) * kind(faces) - call write_binary_xml(dname, fname, c_loc(faces), bytes, & - kind(faces), dtype, digest) - call write_attribute_xml(lun, "faces", fname, 'int32', & - shape(faces), bytes, dtype, digest) + call write_binary_xml(rpath, "faces", "metablock_faces", & + c_loc(faces), bytes, "int32", shape(faces), & + htype, snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock faces!") #endif /* NDIMS == 3 */ - write(fname,"(a,'.bin')") "metablock_edges" bytes = size(edges, kind=8) * kind(edges) - call write_binary_xml(dname, fname, c_loc(edges), bytes, & - kind(edges), dtype, digest) - call write_attribute_xml(lun, "edges", fname, 'int32', & - shape(edges), bytes, dtype, digest) + call write_binary_xml(rpath, "edges", "metablock_edges", & + c_loc(edges), bytes, "int32", shape(edges), & + htype, snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock edges!") - write(fname,"(a,'.bin')") "metablock_corners" bytes = size(corners, kind=8) * kind(corners) - call write_binary_xml(dname, fname, c_loc(corners), bytes, & - kind(corners), dtype, digest) - call write_attribute_xml(lun, "corners", fname, 'int32', & - shape(corners), bytes, dtype, digest) + call write_binary_xml(rpath, "corners", "metablock_corners", & + c_loc(corners), bytes, "int32", shape(corners), & + htype, snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock corners!") - write(fname,"(a,'.bin')") "metablock_bounds" bytes = size(bounds, kind=8) * kind(bounds) - call write_binary_xml(dname, fname, c_loc(bounds), bytes, & - kind(bounds), dtype, digest) - call write_attribute_xml(lun, "bounds", fname, 'float64', & - shape(bounds), bytes, dtype, digest) + call write_binary_xml(rpath, "bounds", "metablock_bounds", & + c_loc(bounds), bytes, "float64", shape(bounds), & + htype, snapshot_compressor, & + compression_level, snapshot_encoder, & + xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock bounds!") if (nmodes > 0) then - write(fname,"(a,'.bin')") "forcing_coefficients" bytes = size(fcoefs, kind=8) * kind(fcoefs) * 2 - call write_binary_xml(dname, fname, c_loc(fcoefs), bytes, & - kind(fcoefs), dtype, digest) - call write_attribute_xml(lun, "forcing", fname, 'complex64', & - shape(fcoefs), bytes, dtype, digest) + call write_binary_xml(rpath, "forcing", "forcing_coefficients", & + c_loc(fcoefs), bytes, "complex64", & + shape(fcoefs), htype, snapshot_compressor, & + compression_level, snapshot_encoder, & + xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store forcing coefficients!") end if #if NDIMS == 3 @@ -2279,34 +2052,24 @@ module io end if #if NDIMS == 3 #endif /* NDIMS == 3 */ - write(lun,"(a)") '' - write(lun,"(a)") '' - close(lun) + + call XMLSaveTree(xml_ptr, trim(rpath) // "metadata.xml") + call XMLFreeTree(xml_ptr) end if - write(fname,sfmt) trim(dname), "datablocks", nproc, "xml" - open(newunit = lun, file = fname, status = 'replace') - write(lun,"(a)") "" - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "nprocs" , nprocs) - call write_attribute_xml(lun, "nproc" , nproc) - call write_attribute_xml(lun, "ndims" , NDIMS) - call write_attribute_xml(lun, "ncells" , ncells) - call write_attribute_xml(lun, "nghosts", nghosts) - call write_attribute_xml(lun, "bcells" , nn) - call write_attribute_xml(lun, "dblocks", nd) - call write_attribute_xml(lun, "nregs" , nr) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "einj" , einj) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "gentype", gentype) - call write_attribute_xml(lun, "nseeds" , nseeds) - write(lun,"(a)") '' - write(lun,"(a)") '' + call XMLInitTree(xml_ptr) + call XMLAddElement(xml_ptr, "DataBlocks", "nprocs" , nprocs) + call XMLAddElement(xml_ptr, "DataBlocks", "nproc" , nproc ) + call XMLAddElement(xml_ptr, "DataBlocks", "ndims" , NDIMS) + call XMLAddElement(xml_ptr, "DataBlocks", "ncells" , ncells) + call XMLAddElement(xml_ptr, "DataBlocks", "nghosts", nghosts) + call XMLAddElement(xml_ptr, "DataBlocks", "bcells" , nn) + call XMLAddElement(xml_ptr, "DataBlocks", "dblocks", nd) + call XMLAddElement(xml_ptr, "DataBlocks", "nregs" , nr) + call XMLAddElement(xml_ptr, "Forcing" , "einj" , einj) + call XMLAddElement(xml_ptr, "Random" , "gentype", gentype) + call XMLAddElement(xml_ptr, "Random" , "nseeds" , nseeds) if (nd > 0) then @@ -2321,31 +2084,40 @@ module io l = l + 1 ids(l) = pdata%meta%id - write(aname,"('_',i6.6)") l - write(fname,"('datablock_prim_',i6.6,a,'.bin')") nproc, trim(aname) bytes = size(pdata%q, kind=8) * kind(pdata%q) - call write_binary_xml(dname, fname, c_loc(pdata%q), bytes, & - kind(pdata%q), dtype, digest) - call write_attribute_xml(lun, "prim" // trim(aname), fname, & - 'float64', shape(pdata%q), bytes, dtype, digest) + write(str,"('prim_',i6.6)") l + aname = trim(str) + write(str,"('datablock_prim_',i6.6,'_',i6.6)") nproc, l + call write_binary_xml(rpath, aname, trim(str), c_loc(pdata%q), & + bytes, "float64", shape(pdata%q), htype, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store primitive variables!") - write(fname,"('datablock_cons_',i6.6,a,'.bin')") nproc, trim(aname) bytes = size(pdata%uu, kind=8) * kind(pdata%uu) - call write_binary_xml(dname, fname, c_loc(pdata%uu), bytes, & - kind(pdata%uu), dtype, digest) - call write_attribute_xml(lun, "cons" // trim(aname), fname, & - 'float64', shape(pdata%uu), bytes, dtype, digest) + write(str,"('cons_',i6.6)") l + aname = trim(str) + write(str,"('datablock_cons_',i6.6,'_',i6.6)") nproc, l + call write_binary_xml(rpath, aname, trim(str), c_loc(pdata%uu), & + bytes, "float64", shape(pdata%uu), htype, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store conservative variables!") pdata => pdata%next end do - write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc bytes = size(ids, kind=8) * kind(ids) - call write_binary_xml(dname, fname, c_loc(ids), bytes, & - kind(ids), dtype, digest) - call write_attribute_xml(lun, "ids", fname, 'int32', & - shape(ids), bytes, dtype, digest) + write(str,"('datablock_ids_',i6.6)") nproc + call write_binary_xml(rpath, "ids", trim(str), c_loc(ids), & + bytes, "int32", shape(ids), htype, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store block IDs!") if (allocated(ids)) deallocate(ids) @@ -2363,25 +2135,29 @@ module io call get_seeds(seeds(:,:)) - write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc bytes = size(seeds, kind=8) * kind(seeds) - call write_binary_xml(dname, fname, c_loc(seeds), bytes, & - kind(seeds), dtype, digest) - call write_attribute_xml(lun, "seeds", fname, 'int64', & - shape(seeds), bytes, dtype, digest) + write(str,"('random_seeds_',i6.6)") nproc + call write_binary_xml(rpath, 'seeds', trim(str), c_loc(seeds), & + bytes, "int64", shape(seeds), htype, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store random seeds!") if (allocated(seeds)) deallocate(seeds) else - call print_message(loc, "Cannot allocate space for random generator seeds!") + call print_message(loc, & + "Cannot allocate space for random generator seeds!") status = 1001 return end if - write(lun,"(a)") '' - write(lun,"(a)") '' - close(lun) + write(str,"(a,'datablocks_',i6.6,'.xml')") trim(rpath), nproc + + call XMLSaveTree(xml_ptr, trim(str)) + call XMLFreeTree(xml_ptr) !------------------------------------------------------------------------------- ! @@ -2420,20 +2196,24 @@ module io use mpitools , only : nprocs, nproc use parameters , only : get_parameter_file use sources , only : viscosity, resistivity + use XML , only : XMLNode, XMLAddElement, & + XMLInitTree, XMLFreeTree, XMLSaveTree implicit none - character(len=*), intent(in) :: problem - integer , intent(out) :: status + character(len=*), intent(in ) :: problem + integer , intent( out) :: status + + character(len=*), parameter :: loc = "IO::store_snapshot_xml()" logical :: test - character(len=64) :: dname, fname - character(len=256) :: vars - integer(kind=8) :: dbytes = 0_8, ddigest = 0_8 - integer(kind=8) :: cbytes = 0_8, cdigest = 0_8 - integer(kind=4) :: lun = 103 + character(len=128) :: str + integer(kind=8) :: bytes integer :: nd, nl, l, p + character(len=:), allocatable :: rpath, cmd, vars + + type(XMLNode) , pointer :: xml_ptr type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata @@ -2442,103 +2222,83 @@ module io real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds real(kind=8) , dimension(:,:,:,:), allocatable, target :: array - character(len=*), parameter :: loc = "IO::store_snapshot_xml()" - character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" - !------------------------------------------------------------------------------- ! status = 0 - write(dname, "('snapshot-',i9.9)") isnap + write(str, "('snapshot-',i9.9,'/')") isnap + rpath = trim(str) + cmd = "mkdir -p " // trim(rpath) #ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) + inquire(directory=rpath, exist=test) do while(.not. test) - if (.not. test) call execute_command_line("mkdir -p " // trim(dname)) - inquire(directory = dname, exist = test) + if (.not. test) call execute_command_line(cmd) + inquire(directory=rpath, exist=test) end do #else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) + inquire(file=rpath, exist=test) do while(.not. test) - if (.not. test) call execute_command_line("mkdir -p " // trim(dname)) - inquire(file = dname, exist = test) + if (.not. test) call execute_command_line(cmd) + inquire(file=rpath, exist=test) end do #endif /* __INTEL_COMPILER */ - dname = trim(dname) // "/" nd = get_dblocks() nl = get_nleafs() - vars = "" - do l = 1, nv - vars = trim(vars) // " " // trim(pvars(l)) - end do + + write(str, "(20(a,1x))") pvars + vars = trim(str) if (nproc == 0) then - call get_parameter_file(fname, status) + call get_parameter_file(str, status) + cmd = "cp -a " // trim(str) // " " // rpath if (status == 0) then - call execute_command_line("cp -a " // trim(fname) // " " // trim(dname)) + call execute_command_line(cmd) else call print_message(loc, "Cannot get the location of parameter file!") return end if - write(fname,"(a,'metadata.xml')") trim(dname) - open(newunit = lun, file = fname, status = 'replace') - write(lun,"(a)") "" - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "problem" , problem) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "nprocs" , nprocs) - call write_attribute_xml(lun, "nproc" , nproc) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "eqsys" , eqsys) - call write_attribute_xml(lun, "eos" , eos) - call write_attribute_xml(lun, "nvars" , nv) - call write_attribute_xml(lun, "adiabatic_index", adiabatic_index) - call write_attribute_xml(lun, "sound_speed" , csnd) - call write_attribute_xml(lun, "viscosity" , viscosity) - call write_attribute_xml(lun, "resistivity" , resistivity) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "ndims" , NDIMS) - call write_attribute_xml(lun, "xblocks" , bdims(1)) - call write_attribute_xml(lun, "yblocks" , bdims(2)) + call XMLInitTree(xml_ptr) + call XMLAddElement(xml_ptr, "Problem" , "problem" , problem) + call XMLAddElement(xml_ptr, "Parallelization", "nprocs" , nprocs) + call XMLAddElement(xml_ptr, "Parallelization", "nproc" , nproc ) + call XMLAddElement(xml_ptr, "Physics" , "eqsys" , eqsys ) + call XMLAddElement(xml_ptr, "Physics" , "eos" , eos ) + call XMLAddElement(xml_ptr, "Physics" , "nvars" , nv ) + call XMLAddElement(xml_ptr, "Physics" , "adiabatic_index", adiabatic_index) + call XMLAddElement(xml_ptr, "Physics" , "sound_speed" , csnd) + call XMLAddElement(xml_ptr, "Physics" , "viscosity" , viscosity) + call XMLAddElement(xml_ptr, "Physics" , "resistivity" , resistivity) + call XMLAddElement(xml_ptr, "Geometry" , "ndims" , NDIMS ) + call XMLAddElement(xml_ptr, "Geometry" , "xblocks" , bdims(1)) + call XMLAddElement(xml_ptr, "Geometry" , "yblocks" , bdims(2)) #if NDIMS == 3 - call write_attribute_xml(lun, "zblocks" , bdims(3)) + call XMLAddElement(xml_ptr, "Geometry" , "zblocks" , bdims(3)) #endif /* NDIMS */ - call write_attribute_xml(lun, "xmin" , xmin) - call write_attribute_xml(lun, "xmax" , xmax) - call write_attribute_xml(lun, "ymin" , ymin) - call write_attribute_xml(lun, "ymax" , ymax) + call XMLAddElement(xml_ptr, "Geometry" , "xmin" , xmin) + call XMLAddElement(xml_ptr, "Geometry" , "xmax" , xmax) + call XMLAddElement(xml_ptr, "Geometry" , "ymin" , ymin) + call XMLAddElement(xml_ptr, "Geometry" , "ymax" , ymax) #if NDIMS == 3 - call write_attribute_xml(lun, "zmin" , zmin) - call write_attribute_xml(lun, "zmax" , zmax) + call XMLAddElement(xml_ptr, "Geometry" , "zmin" , zmin) + call XMLAddElement(xml_ptr, "Geometry" , "zmax" , zmax) #endif /* NDIMS */ - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "minlev" , minlev) - call write_attribute_xml(lun, "maxlev" , maxlev) - call write_attribute_xml(lun, "ncells" , ncells) - call write_attribute_xml(lun, "nghosts" , nghosts) - call write_attribute_xml(lun, "bcells" , nn) - call write_attribute_xml(lun, "nleafs" , nl) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "step" , step) - call write_attribute_xml(lun, "time" , time) - call write_attribute_xml(lun, "dt" , dt) - call write_attribute_xml(lun, "cfl" , cfl) - call write_attribute_xml(lun, "glm_alpha", glm_alpha) - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "isnap" , isnap) - call write_attribute_xml(lun, "variables", trim(vars)) - write(lun,"(a)") '' - write(lun,"(a)") '' + call XMLAddElement(xml_ptr, "Mesh" , "minlev" , minlev) + call XMLAddElement(xml_ptr, "Mesh" , "maxlev" , maxlev) + call XMLAddElement(xml_ptr, "Mesh" , "ncells" , ncells) + call XMLAddElement(xml_ptr, "Mesh" , "nghosts" , nghosts) + call XMLAddElement(xml_ptr, "Mesh" , "bcells" , nn) + call XMLAddElement(xml_ptr, "Mesh" , "nleafs" , nl) + call XMLAddElement(xml_ptr, "Evolution", "step" , step) + call XMLAddElement(xml_ptr, "Evolution", "time" , time) + call XMLAddElement(xml_ptr, "Evolution", "dt" , dt) + call XMLAddElement(xml_ptr, "Evolution", "cfl" , cfl) + call XMLAddElement(xml_ptr, "Evolution", "glm_alpha" , glm_alpha) + call XMLAddElement(xml_ptr, "Snapshots", "isnap" , isnap) + call XMLAddElement(xml_ptr, "Snapshots", "variables" , trim(vars)) allocate(fields(8,nl), bounds(3,2,nl), stat = status) @@ -2572,19 +2332,23 @@ module io pmeta => pmeta%next end do - write(fname,"(a,'.bin')") "metablock_fields" - dbytes = size(fields, kind=8) * kind(fields) - call write_binary_xml(dname, fname, c_loc(fields), dbytes, & - kind(fields), hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "fields", fname, 'int32', & - shape(fields), dbytes, hash_type, ddigest, cbytes, cdigest) + bytes = size(fields, kind=8) * kind(fields) + call write_binary_xml(rpath, "fields", "metablock_fields", & + c_loc(fields), bytes, "int32", shape(fields), & + hash_type, snapshot_compressor, & + compression_level, snapshot_encoder, & + xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock fields!") - write(fname,"(a,'.bin')") "metablock_bounds" - dbytes = size(bounds, kind=8) * kind(bounds) - call write_binary_xml(dname, fname, c_loc(bounds), dbytes, & - kind(bounds), hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "bounds", fname, 'float64', & - shape(bounds), dbytes, hash_type, ddigest, cbytes, cdigest) + bytes = size(bounds, kind=8) * kind(bounds) + call write_binary_xml(rpath, "bounds", "metablock_bounds", & + c_loc(bounds), bytes, "float64", shape(bounds), & + hash_type, snapshot_compressor, & + compression_level, snapshot_encoder, & + xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store metablock bounds!") if (allocated(fields)) deallocate(fields) if (allocated(bounds)) deallocate(bounds) @@ -2595,30 +2359,21 @@ module io return end if - write(lun,"(a)") '' - write(lun,"(a)") '' - close(lun) + call XMLSaveTree(xml_ptr, trim(rpath) // "metadata.xml") + call XMLFreeTree(xml_ptr) end if ! meta data file is stored only on the master process -! prepare and store data block info -! - write(fname,sfmt) trim(dname), "datablocks", nproc, "xml" - open(newunit = lun, file = fname, status = 'replace') - write(lun,"(a)") "" - write(lun,"(a)") '' - write(lun,"(a)") '' - call write_attribute_xml(lun, "nprocs" , nprocs) - call write_attribute_xml(lun, "nproc" , nproc) - call write_attribute_xml(lun, "ndims" , NDIMS) - call write_attribute_xml(lun, "ncells" , ncells) - call write_attribute_xml(lun, "nghosts" , nghosts) - call write_attribute_xml(lun, "bcells" , nn) - call write_attribute_xml(lun, "nvars" , nv) - call write_attribute_xml(lun, "dblocks" , nd) - call write_attribute_xml(lun, "variables", trim(vars)) - write(lun,"(a)") '' - write(lun,"(a)") '' + call XMLInitTree(xml_ptr) + call XMLAddElement(xml_ptr, "DataBlocks", "nprocs" , nprocs) + call XMLAddElement(xml_ptr, "DataBlocks", "nproc" , nproc ) + call XMLAddElement(xml_ptr, "DataBlocks", "ndims" , NDIMS) + call XMLAddElement(xml_ptr, "DataBlocks", "ncells" , ncells) + call XMLAddElement(xml_ptr, "DataBlocks", "nghosts", nghosts) + call XMLAddElement(xml_ptr, "DataBlocks", "bcells" , nn) + call XMLAddElement(xml_ptr, "DataBlocks", "nvars" , nv) + call XMLAddElement(xml_ptr, "DataBlocks", "dblocks", nd) + call XMLAddElement(xml_ptr, "DataBlocks", "variables", trim(vars)) if (nd > 0) then @@ -2639,18 +2394,21 @@ module io pdata => pdata%next end do ! data blocks - write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc - dbytes = size(ids, kind=8) * kind(ids) - call write_binary_xml(dname, fname, c_loc(ids), dbytes, & - kind(ids), hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "ids", fname, 'int32', shape(ids), & - dbytes, hash_type, ddigest, cbytes, cdigest) + bytes = size(ids, kind=8) * kind(ids) + write(str, "('datablock_ids_',i6.6)") nproc + call write_binary_xml(rpath, "ids", trim(str), c_loc(ids), & + bytes, "int32", shape(ids), hash_type, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store block IDs!") - dbytes = size(array, kind=8) * kind(array) + bytes = size(array, kind=8) * kind(array) do p = 1, nv l = 0 + pdata => list_data do while(associated(pdata)) l = l + 1 @@ -2659,12 +2417,15 @@ module io pdata => pdata%next end do - write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", & - trim(pvars(p)), nproc - call write_binary_xml(dname, fname, c_loc(array), dbytes, & - kind(array), hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, pvars(p), fname, 'float64', & - shape(array), dbytes, hash_type, ddigest, cbytes, cdigest) + write(str,"('datablock_',a,'_',i6.6)") trim(pvars(p)), nproc + call write_binary_xml(rpath, pvars(p), trim(str), c_loc(array), & + bytes, "float64", shape(array), hash_type, & + snapshot_compressor, compression_level, & + snapshot_encoder, xml_ptr, status) + if (status /= 0) & + call print_message(loc, "Could not store variable '" // & + trim(pvars(p)) // "'!") + end do if (allocated(ids)) deallocate(ids) @@ -2674,13 +2435,14 @@ module io call print_message(loc, "Cannot allocate space for datablocks!") status = 1001 return - end if ! allocation + end if end if - write(lun,"(a)") '' - write(lun,"(a)") '' - close(lun) + write(str,"(a,'datablocks_',i6.6,'.xml')") trim(rpath), nproc + + call XMLSaveTree(xml_ptr, trim(str)) + call XMLFreeTree(xml_ptr) !------------------------------------------------------------------------------- ! @@ -2688,270 +2450,228 @@ module io ! !=============================================================================== ! -! subroutine WRITE_ATTRIBUTE_XML_STRING: -! ------------------------------------- +! subroutine READ_BINARY_XML: +! -------------------------- ! -! Subroutine writes a string attribute in XML format to specified -! file handler. +! This subroutine serves the purpose of reading binary data from +! a specified data path and array name, while also performing integrity +! checks using hash functions and processing associated XML metadata. ! ! Arguments: ! -! lun - the file handler to write to; -! aname - the name of attribute; -! avalue - the value of attribute; +! data_path - The file path indicating the location of the stored data. +! array_name - The name of the target array for data reading. +! array_ptr - A pointer intended to hold the read data from the array. +! array_bytes - The allocated size in bytes for the array. +! xml_ptr - A pointer referring to an XML tree containing +! associated metadata. +! status - A flag conveying the status of the subroutine. ! !=============================================================================== ! - subroutine write_attribute_xml_string(lun, aname, avalue) + subroutine read_binary_xml(data_path, array_name, array_ptr, array_bytes, & + xml_ptr, status) + + use compression , only : get_compressor_id, decompress + use compression , only : get_encoder_id, decode + use hash , only : hash_info, check_digest, digest_integer + use helpers , only : print_message + use iso_c_binding, only : c_loc, c_ptr, c_f_pointer + use XML , only : XMLNode, XMLGetElementValue, & + XMLHasAttribute, XMLGetAttributeValue implicit none -! input and output arguments -! - integer , intent(in) :: lun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: avalue + character(len=*) , intent(in ) :: data_path, array_name + type(c_ptr) , intent(in ) :: array_ptr + integer(kind=8) , intent(in ) :: array_bytes + type(XMLNode), pointer, intent(in ) :: xml_ptr + integer , intent( out) :: status -! local parameters -! - character(len=*), parameter :: afmt = "('',a,'')" -! -!------------------------------------------------------------------------------- -! - write(lun,afmt) "string", trim(adjustl(aname)), trim(adjustl(avalue)) + character(len=*), parameter :: loc = "IO::read_binary_xml()" + + logical :: test + character(len=256) :: str + character(len=:), allocatable :: file_path, compressor, encoder + integer :: io, item_size + integer :: digest_type, digest_length + integer :: compressor_id, encoder_id + integer(kind=8) :: hash, usize, csize + integer(kind=1), dimension(:), pointer :: array + integer(kind=1), dimension(:), allocatable, target :: buffer !------------------------------------------------------------------------------- ! - end subroutine write_attribute_xml_string -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_XML_INTEGER: -! -------------------------------------- -! -! Subroutine writes an integer attribute in XML format to specified -! file handler. -! -! Arguments: -! -! lun - the file handler to write to; -! aname - the name of attribute; -! avalue - the value of attribute; -! -!=============================================================================== -! - subroutine write_attribute_xml_integer(lun, aname, avalue) + status = 0 - implicit none + compressor = '' + encoder = '' -! input and output arguments -! - integer , intent(in) :: lun - character(len=*), intent(in) :: aname - integer(kind=4) , intent(in) :: avalue - -! local variables -! - character(len=32) :: svalue - -! local parameters -! - character(len=*), parameter :: afmt = "('',a,'')" -! -!------------------------------------------------------------------------------- -! - write(svalue,"(1i32)") avalue - write(lun,afmt) "integer", trim(adjustl(aname)), trim(adjustl(svalue)) - -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_xml_integer -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_XML_DOUBLE: -! -------------------------------------- -! -! Subroutine writes a double precision attribute in XML format to specified -! file handler. -! -! Arguments: -! -! lun - the file handler to write to; -! aname - the name of attribute; -! avalue - the value of attribute; -! -!=============================================================================== -! - subroutine write_attribute_xml_double(lun, aname, avalue) - - implicit none - -! input and output arguments -! - integer , intent(in) :: lun - character(len=*), intent(in) :: aname - real(kind=8) , intent(in) :: avalue - -! local variables -! - character(len=32) :: svalue - -! local parameters -! - character(len=*), parameter :: afmt = "('',a,'')" -! -!------------------------------------------------------------------------------- -! - write(svalue,"(1es32.20)") avalue - write(lun,afmt) "double", trim(adjustl(aname)), trim(adjustl(svalue)) - -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_xml_double -! -!=============================================================================== -! -! subroutine WRITE_ATTRIBUTE_XML_FILE: -! ----------------------------------- -! -! Subroutine writes a file attribute in XML format to specified file handler. -! -! Arguments: -! -! lun - the file handler to write to; -! aname - the file attribute name; -! filename - the file name; -! data_type - the data type of the input data; -! data_shape - the shape of the input data; -! digest_string - the digest type string; -! data_bytes - the file size in bytes; -! data_digest - the digest of the file content; -! compressed_bytes - the size of the compressed data in bytes; -! compressed_digest - the digest of the compressed data; -! -!=============================================================================== -! - subroutine write_attribute_xml_file(lun, aname, filename, & - data_type, data_shape, & - data_bytes, digest_type, data_digest, & - compressed_bytes, compressed_digest) - - use compression, only : compression_suffix - use hash , only : hash_name, digest_string - - implicit none - - integer , intent(in) :: lun - character(len=*) , intent(in) :: aname, filename, data_type - integer , intent(in) :: digest_type - integer, dimension(:) , intent(in) :: data_shape - integer(kind=8) , intent(in) :: data_bytes, data_digest - integer(kind=8) , optional, intent(in) :: compressed_bytes - integer(kind=8) , optional, intent(in) :: compressed_digest - - character(len=256) :: fname - character(len=1024) :: string - character(len=128) :: str - integer :: n - -!------------------------------------------------------------------------------- -! - fname = filename - string = ' 0) then - fname = trim(fname) // trim(compression_suffix) - write(str,"(1i0)") compressed_bytes - string = trim(string) // & - ' compression_format="' // trim(adjustl(cformat)) // & - '" compressed_size="' // trim(adjustl(str)) // '"' - if (present(compressed_digest)) then - if (compressed_digest /= 0) then - call digest_string(compressed_digest, str) - string = trim(string) // & - ' compressed_digest="' // trim(adjustl(str)) // '"' - end if - end if - select case(data_filter) - case(1) - string = trim(string) // ' data_filter="shuffle"' - case(2) - string = trim(string) // ' data_filter="bytedelta"' - end select - end if + call XMLGetElementValue(xml_ptr, 'BinaryFiles', array_name, str) + file_path = trim(data_path) // trim(str) + inquire(file=file_path, exist=test) + if (.not. test) then + call print_message(loc, "The file '" // trim(file_path) // & + "' does not exist.") + status = 121 + return end if - string = trim(string) // '>' // trim(adjustl(fname)) // '' - write(lun,'(a)') trim(adjustl(string)) -!------------------------------------------------------------------------------- -! - end subroutine write_attribute_xml_file + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, 'size', usize) + if (usize /= array_bytes) then + call print_message(loc, "Array size mismatch. The size of the array '" & + // trim(array_name) // "' in memory " // & + "does not match the stored array size.") + status = 1 + return + end if + + call c_f_pointer(array_ptr, array, [ array_bytes ]) + + test = XMLHasAttribute(xml_ptr, 'BinaryFiles', array_name, & + 'compression_format') + if (test) then + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'compression_format', str) + compressor = trim(str) + test = compressor /= 'none' + end if + + if (test) then + compressor_id = get_compressor_id(compressor) + + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'compressed_size', csize) + allocate(buffer(csize)) + + open(newunit=io, file=file_path, access='stream') + read(io) buffer + close(io) + + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'digest_type', str) + call hash_info(trim(str), digest_type, digest_length) + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'compressed_digest', str) + call digest_integer(trim(str), hash) + call check_digest(loc, file_path, c_loc(buffer), csize, hash, digest_type) + + call decompress(compressor_id, c_loc(buffer), csize, array_ptr, usize, status) + + if (status /= 0) then + call print_message(loc, "Array size mismatch. The size of the array '" & + // trim(array_name) // "' in memory " // & + "does not match the decompressed array size.") + status = 1 + return + end if + + deallocate(buffer) + + test = XMLHasAttribute(xml_ptr, 'BinaryFiles', array_name, 'data_encoder') + if (test) then + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'data_encoder', str) + encoder = trim(str) + test = encoder /= 'none' + end if + + if (test) then + encoder_id = get_encoder_id(encoder) + + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'data_type', str) + select case(str) + case('complex64', 'float64', 'int64') + item_size = 8 + case('float32', 'int32') + item_size = 4 + case default + item_size = 1 + end select + + allocate(buffer(usize)) + buffer = array + call decode(encoder_id, item_size, array_bytes, c_loc(buffer), array) + deallocate(buffer) + + end if + + else + open(newunit=io, file=file_path, access='stream') + read(io) array + close(io) + end if + + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'digest_type', str) + call hash_info(trim(str), digest_type, digest_length) + call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & + 'digest', str) + call digest_integer(trim(str), hash) + call check_digest(loc, file_path, array_ptr, array_bytes, hash, digest_type) + + end subroutine read_binary_xml ! !=============================================================================== ! ! subroutine WRITE_BINARY_XML: ! --------------------------- ! -! Subroutine writes the input array of bytes in a binary file with -! the provided path and name, and returns the digest of written data. +! This subroutine is designed to write compressed binary data to a specified +! file path and array name. It includes functionality for ensuring data +! integrity through hash functions, as well as storing relevant metadata +! in XML format. ! ! Arguments: ! -! path, name - the path and name where the array should be written to; -! array_ptr - the pointer to the array to store; -! array_bytes - the size of the array in bytes; -! item_size - the size of element; -! digest_type - the type of digest to hash the data; -! array_digest - the digest of the original array; -! compressed_bytes - the size of the compressed array in bytes; -! compressed_digest - the digest of the compressed array; +! data_path - The file path indicating the location of the stored data. +! array_name - The name of the target array for data reading. +! array_ptr - A pointer intended to hold the read data from the array. +! array_bytes - The allocated size in bytes for the array. +! array_dtype - The data type of the array elements. +! array_dims - The dimensions (shape) of the array. +! digest_id - The method ID used for calculating hashes. +! compressor_id - The method ID used for compression of the array. +! level - The compression level. +! encoder_id - The method ID used for data encoding before compression. +! xml_ptr - A pointer referring to an XML tree containing +! associated metadata. +! status - A flag conveying the status of the subroutine. ! !=============================================================================== ! - subroutine write_binary_xml(path, name, array_ptr, array_bytes, item_size, & - digest_type, array_digest, & - compressed_bytes, compressed_digest) + subroutine write_binary_xml(data_path, array_name, array_file, array_ptr, & + array_bytes, array_dtype, array_dims, & + digest_id, compressor_id, level, & + encoder_id, xml_ptr, status) - use compression , only : get_compression, compression_bound, compress - use compression , only : compression_suffix, encode - use hash , only : digest - use iso_c_binding, only : c_ptr, c_loc, c_f_pointer + use compression , only : is_compressor_on, is_encoder_on, & + get_compressor_name, get_encoder_name, & + get_compressed_file_suffix, compression_bound, & + encode, compress + use hash , only : hash_name, digest, digest_string + use iso_c_binding, only : c_loc, c_ptr, c_f_pointer + use XML , only : XMLNode, XMLAddElement implicit none - character(len=*), intent(in) :: path, name - type(c_ptr) , intent(in) :: array_ptr - integer(kind=4) , intent(in) :: item_size - integer(kind=8) , intent(in) :: array_bytes + character(len=*) , intent(in ) :: data_path, array_name, & + array_file, array_dtype + type(c_ptr) , intent(in ) :: array_ptr + integer(kind=8) , intent(in ) :: array_bytes + integer, dimension(:) , intent(in ) :: array_dims + integer , intent(in ) :: digest_id + integer , intent(in ) :: compressor_id, level, encoder_id + type(XMLNode), pointer, intent(inout) :: xml_ptr + integer , intent( out) :: status - integer , intent(in) :: digest_type - integer(kind=8), optional , intent(out) :: compressed_bytes - integer(kind=8), optional , intent(out) :: array_digest - integer(kind=8), optional , intent(out) :: compressed_digest - - character(len=512) :: fname - integer :: lun = 123 - logical :: written - integer :: status + character(len=1024) :: str + character(len=:), allocatable :: filename, filepath, file_suffix + character(len=:), allocatable :: digest_name, compressor_name, encoder_name + character(len=:), allocatable :: uhash, chash + integer(kind=8) :: hash, cbytes + integer :: io, item_size integer(kind=1), dimension(:), pointer :: array @@ -2960,54 +2680,106 @@ module io !------------------------------------------------------------------------------- ! - status = 0 - written = .false. - if (present(array_digest)) & - array_digest = digest(array_ptr, array_bytes, digest_type) + status = 0 -! try to compress the array and store it if compression was successful -! - if (present(compressed_bytes) .and. get_compression() > 0) then - compressed_bytes = compression_bound(array_bytes) - allocate(input(array_bytes), buffer(compressed_bytes), stat = status) - if (status == 0) then - input_ptr = c_loc(input) - buffer_ptr = c_loc(buffer) - call encode(data_filter, item_size, array_bytes, array_ptr, input) - call compress(input_ptr, array_bytes, buffer_ptr, compressed_bytes) - if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then - write(fname,"(a,'/',a,a)") trim(path), trim(name), & - trim(compression_suffix) - open(newunit=lun, file=fname, form='unformatted', & - access='stream', status='replace') - write(lun) buffer(1:compressed_bytes) - close(lun) - written = .true. - if (present(compressed_digest)) & - compressed_digest = digest(buffer_ptr, & - compressed_bytes, digest_type) - else - compressed_bytes = 0 - compressed_digest = 0 - end if - deallocate(input, buffer) + digest_name = hash_name(digest_id) + + hash = digest(array_ptr, array_bytes, digest_id) + call digest_string(hash, str) + uhash = trim(str) + chash = '' + + filename = '' + encoder_name = '' + + if (is_compressor_on(compressor_id)) then + + compressor_name = trim(get_compressor_name(compressor_id)) + file_suffix = trim(get_compressed_file_suffix(compressor_id)) + + if (is_encoder_on(encoder_id)) then + + encoder_name = trim(get_encoder_name(encoder_id)) + + select case(array_dtype) + case('complex64', 'float64', 'int64') + item_size = 8 + case('float32', 'int32') + item_size = 4 + case default + item_size = 1 + end select + + allocate(input(array_bytes), stat = status) + + call encode(encoder_id, item_size, array_bytes, array_ptr, input) + + input_ptr = c_loc(input) + else + input_ptr = array_ptr end if - end if -! compression failed or no compression was used, so write the original array -! - if (.not. written) then + cbytes = compression_bound(compressor_id, level, array_bytes) + + allocate(buffer(cbytes), stat = status) + + if (status == 0) then + + buffer_ptr = c_loc(buffer) + + call compress(compressor_id, level, & + input_ptr, array_bytes, buffer_ptr, cbytes) + + if (cbytes > 0) then + + filename = trim(array_file) // '.bin' // file_suffix + filepath = trim(data_path) // trim(filename) + + open(newunit=io, file=filepath, access='stream') + write(io) buffer(1:cbytes) + close(io) + + end if + + hash = digest(buffer_ptr, cbytes, digest_id) + call digest_string(hash, str) + chash = trim(str) + + if (allocated(input)) deallocate(input) + if (allocated(buffer)) deallocate(buffer) + + end if + + if (is_encoder_on(encoder_id)) then + call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & + filename, array_dtype, array_bytes, & + array_dims, digest_name, uhash, & + compressor_name, cbytes, chash, & + encoder_name) + else + call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & + filename, array_dtype, array_bytes, & + array_dims, digest_name, uhash, & + compressor_name, cbytes, chash) + end if + + else ! no compression + call c_f_pointer(array_ptr, array, [ array_bytes ]) - write(fname,"(a,'/',a)") trim(path), trim(name) - open(newunit=lun, file=fname, form='unformatted', & - access='stream', status='replace') - write(lun) array - close(lun) + filename = trim(array_file) // '.bin' + filepath = trim(data_path) // trim(filename) + + open(newunit=io, file=filepath, access='stream') + write(io) array + close(io) + + call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & + filename, array_dtype, array_bytes, & + array_dims, digest_name, uhash) + end if -!------------------------------------------------------------------------------- -! end subroutine write_binary_xml #ifdef HDF5 ! diff --git a/sources/xml.F90 b/sources/xml.F90 new file mode 100644 index 0000000..490521e --- /dev/null +++ b/sources/xml.F90 @@ -0,0 +1,1546 @@ +!=============================================================================== +! +! This file is a component of the AMUN source code, a robust and versatile +! framework for conducting numerical simulations in fluid approximation +! on uniform and non-uniform (adaptive) meshes. AMUN is designed for +! magnetohydrodynamic (classical and relativistic) plasma modeling studies +! of astrophysical phenomena. +! +! Copyright (C) 2023 Grzegorz Kowal +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +!=============================================================================== +! +! Name: XML +! +! Description: +! +! The XML module offers a user-friendly interface for parsing, creating, +! manipulating, and saving XML data in Fortran 2003. It introduces two +! primary data structures, XMLNode and XMLAttribute, which effectively +! represent XML elements and attributes. Within this module, you can easily +! initialize XML nodes and attributes, append child nodes and attributes +! to a parent node, parse XML files to construct an XML tree, retrieve +! values of elements and attributes, print the XML tree, and seamlessly +! save XML data back to a file. +! +!------------------------------------------------------------------------------- +! +module XML + + implicit none + + private + +! Module interfaces +! ----------------- +! + interface XMLAddElement + module procedure XMLAddElementString + module procedure XMLAddElementInteger + module procedure XMLAddElementDouble + module procedure XMLAddElementFile + end interface + + interface XMLGetElementValue + module procedure XMLGetElementValueInteger + module procedure XMLGetElementValueDouble + module procedure XMLGetElementValueString + end interface + + interface XMLGetAttributeValue + module procedure XMLGetAttributeValueInteger + module procedure XMLGetAttributeValueLong + module procedure XMLGetAttributeValueDouble + module procedure XMLGetAttributeValueString + end interface + +! Module structures +! ----------------- +! + type XMLNode + character(len=:), allocatable :: name + character(len=:), allocatable :: value + type(XMLAttribute), pointer :: attributes + type(XMLNode) , pointer :: children + type(XMLNode) , pointer :: next + end type XMLNode + + type XMLAttribute + character(len=:), allocatable :: name + character(len=:), allocatable :: value + type(XMLAttribute), pointer :: next + end type XMLAttribute + +! Public members +! -------------- +! + public :: XMLNode, XMLAttribute + public :: XMLParseFile, XMLInitTree, XMLFreeTree, XMLSaveTree + public :: XMLAddElement, XMLGetElementValue, XMLGetAttributeValue + public :: XMLHasAttribute + +contains + +!=== PUBLIC SUBROUTINES AND FUNCTIONS === + +!=============================================================================== +! +! subroutine XMLParseFile: +! ----------------------- +! +! Description: +! +! Parses an XML file and builds an XML tree, returning a pointer to its root. +! +! Arguments: +! +! filename - Input filename of the XML file to parse; +! root_ptr - Pointer to the root node of the XML tree; +! status - a flag indicating the status of the subroutine; +! +!=============================================================================== +! + subroutine XMLParseFile(filename, root_ptr, status) + + use helpers, only : print_message + + implicit none + + character(len=*) , intent(in ) :: filename + type(XMLNode), pointer, intent( out) :: root_ptr + integer , intent( out) :: status + + character(len=*), parameter :: loc = "XML::XMLParseFile()" + + integer :: io, filesize, ibeg, iend + + character(:), allocatable :: content + +!------------------------------------------------------------------------------- +! + status = 0 + + inquire(file=filename, size=filesize) + + allocate(character(filesize) :: content) + + open(newunit=io, file=filename, access='stream') + read(io) content + close(io) + + ibeg = index(content, '') + if (iend <= 0) then + call print_message(loc, "File '" // trim(filename) // & + "' seems to be corrupted!") + deallocate(content) + status = -1 + return + end if + iend = iend + ibeg - 1 + + call XMLNodeInit(root_ptr, "AMUNFile") + + call XMLIterateAttributes(trim(content(ibeg:iend)), root_ptr) + + ibeg = iend + 1 + iend = index(content, '') - 1 + if (iend <= 0) then + call print_message(loc, "File '" // trim(filename) // & + "' seems to be corrupted!") + deallocate(content) + status = -1 + return + end if + + call XMLIterateSections(trim(adjustl(content(ibeg:iend))), root_ptr) + + deallocate(content) + +!------------------------------------------------------------------------------- +! + end subroutine XMLParseFile + +!=============================================================================== +! +! subroutine XMLTreeInit: +! ---------------------- +! +! Description: +! +! Initializes a new XML Tree. +! +! Arguments: +! +! node_ptr - Pointer to the XMLNode to be initialized; +! node_name - Name for the XMLNode; +! node_value - Optional value for the XMLNode; +! +!=============================================================================== +! + subroutine XMLInitTree(root_ptr, version) + + implicit none + + type(XMLNode), pointer, intent(inout) :: root_ptr + character(len=*) , intent(in ), optional :: version + + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLNodeInit(root_ptr, "AMUNFile") + if (present(version)) then + call XMLAttributeInit(attr_ptr, "version", trim(version)) + else + call XMLAttributeInit(attr_ptr, "version", "1.0") + end if + call XMLAddAttribute(root_ptr, attr_ptr) + call XMLAttributeInit(attr_ptr, "byte_order", "LittleEndian") + call XMLAddAttribute(root_ptr, attr_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLInitTree + +!=============================================================================== +! +! subroutine XMLFreeTree: +! ---------------------- +! +! Description: +! +! Recursively frees the memory allocated for an XML tree. +! +! Arguments: +! +! node_ptr - Pointer to the node of the XML tree to free; +! +!=============================================================================== +! + recursive subroutine XMLFreeTree(node_ptr) + + implicit none + + type(XMLNode), pointer, intent(inout) :: node_ptr + + type(XMLNode) , pointer :: child_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + attr_ptr => node_ptr%attributes + do while (associated(attr_ptr)) + node_ptr%attributes => attr_ptr%next + deallocate(attr_ptr%name, attr_ptr%value) + deallocate(attr_ptr) + attr_ptr => node_ptr%attributes + end do + + child_ptr => node_ptr%children + do while (associated(child_ptr)) + node_ptr%children => child_ptr%next + call XMLFreeTree(child_ptr) + child_ptr => node_ptr%children + end do + + deallocate(node_ptr%name, node_ptr%value) + deallocate(node_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLFreeTree + +!=============================================================================== +! +! subroutine XMLSaveTree: +! ---------------------- +! +! Description: +! +! Saves an XML tree to a file. +! +! Arguments: +! +! root_ptr - The XML root to save. +! filename - The file name to write to. +! +!=============================================================================== +! + subroutine XMLSaveTree(root_ptr, filename) + + implicit none + + type(XMLNode), pointer, intent(in) :: root_ptr + character(len=*) , intent(in) :: filename + + integer :: io + +!------------------------------------------------------------------------------- +! + open(newunit=io, file=filename) + write (io,"(a)") '' + call XMLSaveNode(io, 1, root_ptr) + close(io) + +!------------------------------------------------------------------------------- +! + end subroutine XMLSaveTree + +!=== PRIVATE SUBROUTINES AND FUNCTIONS === + +!=============================================================================== +! +! subroutine XMLNodeInit: +! ---------------------- +! +! Description: +! +! Initializes an XMLNode with the specified name and optional value. +! +! Arguments: +! +! node_ptr - Pointer to the XMLNode to be initialized; +! node_name - Name for the XMLNode; +! node_value - Optional value for the XMLNode; +! +!=============================================================================== +! + subroutine XMLNodeInit(node_ptr, node_name, node_value) + + implicit none + + type(XMLNode), pointer, intent(inout) :: node_ptr + character(len=*) , intent(in ) :: node_name + character(len=*) , intent(in ), optional :: node_value + +!------------------------------------------------------------------------------- +! + allocate(node_ptr) + + node_ptr%name = node_name + if (present(node_value)) then + node_ptr%value = node_value + else + node_ptr%value = "" + end if + + nullify(node_ptr%attributes) + nullify(node_ptr%children) + nullify(node_ptr%next) + +!------------------------------------------------------------------------------- +! + end subroutine XMLNodeInit + +!=============================================================================== +! +! subroutine XMLAttributeInit: +! --------------------------- +! +! Description: +! +! Initializes an XMLAttribute with the specified name and optional value. +! +! Arguments: +! +! attr_ptr - Pointer to the XMLAttribute to be initialized; +! attr_name - Name for the XMLAttribute; +! attr_value - Optional value for the XMLAttribute; +! +!=============================================================================== +! + subroutine XMLAttributeInit(attr_ptr, attr_name, attr_value) + + implicit none + + type(XMLAttribute), pointer, intent(inout) :: attr_ptr + character(len=*) , intent(in ) :: attr_name + character(len=*) , intent(in ), optional :: attr_value + +!------------------------------------------------------------------------------- +! + allocate(attr_ptr) + + attr_ptr%name = attr_name + if (present(attr_value)) then + attr_ptr%value = attr_value + else + attr_ptr%value = "" + end if + + nullify(attr_ptr%next) + +!------------------------------------------------------------------------------- +! + end subroutine XMLAttributeInit + +!=============================================================================== +! +! subroutine XMLIterateSections: +! ----------------------------- +! +! Description: +! +! Iterates through XML sections in content and builds an XML tree. +! +! Arguments: +! +! content - Input XML content string; +! node_ptr - Pointer to the current XML node being built; +! +!=============================================================================== +! + subroutine XMLIterateSections(content, node_ptr) + + implicit none + + character(len=*) , intent(in ) :: content + type(XMLNode), pointer, intent(inout) :: node_ptr + + type(XMLNode) , pointer :: child_ptr + character(len=:), allocatable :: tag + integer :: ibeg, iend, icur + +!------------------------------------------------------------------------------- +! + icur = 1 + + do while (icur > 0 .and. icur < len(content)) + + ibeg = index(content(icur:), '<') + icur - 1 + iend = index(content(icur:), '>') + icur - 1 + + tag = trim(adjustl(content(ibeg + 1 : iend - 1))) + + call XMLNodeInit(child_ptr, trim(tag)) + call XMLAddChild(node_ptr, child_ptr) + + icur = iend + 1 + iend = index(content(icur:), '') & + + icur + len(trim(tag)) + 1 + + call XMLIterateElements(content(ibeg:iend), child_ptr) + + icur = iend + 1 + + end do + +!------------------------------------------------------------------------------- +! + end subroutine XMLIterateSections + +!=============================================================================== +! +! subroutine XMLIterateElements: +! ----------------------------- +! +! Description: +! +! Iterates through XML elements in content and builds an XML tree. +! +! Arguments: +! +! content - Input XML content string; +! node_ptr - Pointer to the current XML node being built; +! +!=============================================================================== +! + subroutine XMLIterateElements(content, node_ptr) + + implicit none + + character(len=*) , intent(in ) :: content + type(XMLNode), pointer, intent(inout) :: node_ptr + + type(XMLNode) , pointer :: child_ptr + character(len=:), allocatable :: element, name + integer :: icur, ibeg, iend + +!------------------------------------------------------------------------------- +! + icur = 1 + + do while (icur > 0 .and. icur < len(content)) + + ibeg = index(content(icur:), '') + + if (ibeg > 0 .and. iend > 0) then + + ibeg = ibeg + icur - 1 + iend = iend + icur + 10 + + element = trim(adjustl(content(ibeg:iend))) + + icur = iend + 1 + + ibeg = index(element, 'name=') + 6 + iend = index(element(ibeg:), '"') + ibeg - 2 + + name = trim(element(ibeg:iend)) + + ibeg = index(element, '>') + 1 + iend = index(element, ' 0 .and. icur < len(content)) + + ieql = index(content(icur:), '=') + + if (ieql > 0) then + ieql = ieql + icur - 1 + ibeg = index(content(ieql + 1:), '"') + ieql + iend = index(content(ibeg + 1:), '"') + ibeg + + if (.not. trim(adjustl(content(icur:ieql - 1))) == 'name') then + call XMLAttributeInit(attr_ptr, trim(adjustl(content(icur : ieql - 1))), & + trim(adjustl(content(ibeg + 1 : iend - 1)))) + call XMLAddAttribute(node_ptr, attr_ptr) + end if + + icur = iend + 1 + + else + icur = -1 + end if + + end do + +!------------------------------------------------------------------------------- +! + end subroutine XMLIterateAttributes + +!=============================================================================== +! +! subroutine XMLAddChild: +! ---------------------- +! +! Description: +! +! Adds a child node to a parent node in an XML tree. +! +! Arguments: +! +! node_ptr - Pointer to the parent XML node; +! child_ptr - Pointer to the child XML node to be added; +! +!=============================================================================== +! + subroutine XMLAddChild(node_ptr, child_ptr) + + implicit none + + type(XMLNode), pointer, intent(inout) :: node_ptr + type(XMLNode), pointer, intent(in ) :: child_ptr + + type(XMLNode), pointer :: last_ptr + +!------------------------------------------------------------------------------- +! + if (associated(node_ptr%children)) then + last_ptr => node_ptr%children + + do while (associated(last_ptr%next)) + last_ptr => last_ptr%next + end do + + last_ptr%next => child_ptr + else + node_ptr%children => child_ptr + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddChild + +!=============================================================================== +! +! subroutine XMLAddAttribute: +! -------------------------- +! +! Description: +! +! Adds an XMLAttribute to an XMLNode. +! +! Arguments: +! +! node_ptr - Pointer to the parent XML node; +! attr_ptr - Pointer to the XML attribute that will be added; +! +!=============================================================================== +! + subroutine XMLAddAttribute(node_ptr, attr_ptr) + + implicit none + + type(XMLNode) , pointer, intent(inout) :: node_ptr + type(XMLAttribute), pointer, intent(in ) :: attr_ptr + + type(XMLAttribute), pointer :: last_ptr + +!------------------------------------------------------------------------------- +! + if (associated(node_ptr%attributes)) then + last_ptr => node_ptr%attributes + + do while (associated(last_ptr%next)) + last_ptr => last_ptr%next + end do + + last_ptr%next => attr_ptr + else + node_ptr%attributes => attr_ptr + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddAttribute + +!=============================================================================== +! +! subroutine XMLSaveNode: +! ---------------------- +! +! Description: +! +! Saves an XML node to a file. +! +! Arguments: +! +! io - The file unit to write to; +! level - The level of the node in the hierarchy; +! node_ptr - The XML node to save; +! +!=============================================================================== +! + recursive subroutine XMLSaveNode(io, level, node_ptr) + + implicit none + + integer , intent(in) :: io, level + type(XMLNode), pointer, intent(in) :: node_ptr + + character(len=:), allocatable :: node_name + type(XMLAttribute), pointer :: attr_ptr + type(XMLNode) , pointer :: child_ptr + +!------------------------------------------------------------------------------- +! + if (level > 2) then + node_name = 'Attribute' + else + node_name = trim(node_ptr%name) + end if + + write(io, '(A)', advance='no') "<" // node_name + + if (level > 2) then + write(io,"(1x,a,'=',a)", advance='no') & + 'name', '"' // trim(node_ptr%name) // '"' + end if + + attr_ptr => node_ptr%attributes + do while (associated(attr_ptr)) + write(io,"(1x,a,'=',a)", advance='no') trim(attr_ptr%name), & + '"' // trim(attr_ptr%value) // '"' + attr_ptr => attr_ptr%next + end do + + if (level > 2) then + write(io,'(a,a,a)') ">", trim(node_ptr%value), "" + else + write(io,'(a)') ">" + + child_ptr => node_ptr%children + do while(associated(child_ptr)) + call XMLSaveNode(io, level+1, child_ptr) + child_ptr => child_ptr%next + end do + + write(io,'(a)') "" + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLSaveNode + +!=============================================================================== +! +! subroutine XMLFindElement: +! ------------------------- +! +! Description: +! +! Finds an XML element within a specific section of the XML tree. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! node_ptr - Pointer to store the found XML node; +! +!=============================================================================== +! + subroutine XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + use helpers, only : print_message + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + type(XMLNode), pointer, intent( out) :: node_ptr + + character(len=*), parameter :: loc = "XML::XMLFindElement()" + + type(XMLNode), pointer :: child_ptr + +!------------------------------------------------------------------------------- +! + child_ptr => root_ptr%children + + do while (associated(child_ptr)) + if (trim(child_ptr%name) == trim(section_name)) then + node_ptr => child_ptr%children + + do while (associated(node_ptr)) + if (trim(node_ptr%name) == trim(element_name)) return + + node_ptr => node_ptr%next + end do + end if + + child_ptr => child_ptr%next + end do + + call print_message(loc, "Element '" // trim(element_name) // & + "' in section '" // trim(section_name) // & + "' not found!") + +!------------------------------------------------------------------------------- +! + end subroutine XMLFindElement + +!=============================================================================== +! +! subroutine XMLGetAttribute: +! -------------------------- +! +! Description: +! +! Gets the attribute of an XML node by its name. +! +! Arguments: +! +! node_ptr - Pointer to the XML node to search for the attribute; +! attr_name - Input string for the attribute name; +! attr_ptr - Pointer to store the found XML attribute; +! +!=============================================================================== +! + subroutine XMLGetAttribute(node_ptr, attr_name, attr_ptr) + + use helpers, only : print_message + + implicit none + + type(XMLNode), pointer , intent(in ) :: node_ptr + character(len=*) , intent(in ) :: attr_name + type(XMLAttribute), pointer, intent( out) :: attr_ptr + + character(len=*), parameter :: loc = "XML::XMLGetAttribute()" + +!------------------------------------------------------------------------------- +! + attr_ptr => node_ptr%attributes + + do while (associated(attr_ptr)) + if (trim(attr_ptr%name) == trim(attr_name)) return + + attr_ptr => attr_ptr%next + end do + + call print_message(loc, "Attribute '" // trim(attr_name) // & + "' not found in the node '" // & + trim(node_ptr%name) // "'!") + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetAttribute + +!=============================================================================== +! +! subroutine XMLAddElementString: +! ------------------------------ +! +! Description: +! +! This subroutine adds a new element to the specified section of a XML tree. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLAddElementString(root_ptr, section_name, & + element_name, element_value) + + implicit none + + type(XMLNode), pointer, intent(inout) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + character(len=*) , intent(in ) :: element_value + + type(XMLNode) , pointer :: node_ptr, elem_ptr + type(XMLAttribute), pointer :: attr_ptr + + logical :: found + +!------------------------------------------------------------------------------- +! + found = .false. + node_ptr => root_ptr%children + do while (associated(node_ptr) .and. .not. found) + if (trim(node_ptr%name) == trim(section_name)) then + found = .true. + else + node_ptr => node_ptr%next + end if + end do + + if (.not. found) then + call XMLNodeInit(node_ptr, section_name) + call XMLAddChild(root_ptr, node_ptr) + end if + + call XMLNodeInit(elem_ptr, element_name, element_value) + call XMLAttributeInit(attr_ptr, "type", "string") + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAddChild(node_ptr, elem_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddElementString + +!=============================================================================== +! +! subroutine XMLAddElementInteger: +! ------------------------------- +! +! Description: +! +! This subroutine adds a new element to the specified section of a XML tree. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLAddElementInteger(root_ptr, section_name, & + element_name, element_value) + + implicit none + + type(XMLNode), pointer, intent(inout) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + integer(kind=4) , intent(in ) :: element_value + + type(XMLNode) , pointer :: node_ptr, elem_ptr + type(XMLAttribute), pointer :: attr_ptr + + logical :: found + character(len=64) :: str + +!------------------------------------------------------------------------------- +! + found = .false. + node_ptr => root_ptr%children + do while (associated(node_ptr) .and. .not. found) + if (trim(node_ptr%name) == trim(section_name)) then + found = .true. + else + node_ptr => node_ptr%next + end if + end do + + if (.not. found) then + call XMLNodeInit(node_ptr, section_name) + call XMLAddChild(root_ptr, node_ptr) + end if + + write(str,"(i0)") element_value + call XMLNodeInit(elem_ptr, element_name, trim(adjustl(str))) + call XMLAttributeInit(attr_ptr, "type", "integer") + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAddChild(node_ptr, elem_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddElementInteger + +!=============================================================================== +! +! subroutine XMLAddElementDouble: +! ------------------------------- +! +! Description: +! +! This subroutine adds a new element to the specified section of a XML tree. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLAddElementDouble(root_ptr, section_name, & + element_name, element_value) + + implicit none + + type(XMLNode), pointer, intent(inout) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + real(kind=8) , intent(in ) :: element_value + + type(XMLNode) , pointer :: node_ptr, elem_ptr + type(XMLAttribute), pointer :: attr_ptr + + logical :: found + character(len=64) :: str + +!------------------------------------------------------------------------------- +! + found = .false. + node_ptr => root_ptr%children + do while (associated(node_ptr) .and. .not. found) + if (trim(node_ptr%name) == trim(section_name)) then + found = .true. + else + node_ptr => node_ptr%next + end if + end do + + if (.not. found) then + call XMLNodeInit(node_ptr, section_name) + call XMLAddChild(root_ptr, node_ptr) + end if + + write(str,"(1es32.20)") element_value + call XMLNodeInit(elem_ptr, element_name, trim(adjustl(str))) + call XMLAttributeInit(attr_ptr, "type", "double") + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAddChild(node_ptr, elem_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddElementDouble + +!=============================================================================== +! +! subroutine XMLAddElementFile: +! ---------------------------- +! +! Description: +! +! This subroutine is designed to add an XML element to an XML tree structure, +! with various attributes. +! +! Arguments: +! +! root_ptr - A pointer to the root node of the XML tree; +! section_name - The name of the section or parent element under which +! the new XML element should be added; +! element_name - The name of the XML element to be added; +! element_value - The value associated with the XML element; +! element_dtype - The data type of the associated array; +! element_size - The size in bytes of an array stored in an associated +! binary file; +! element_dims - The shape or dimensions of the array stored in +! an associated binary file; +! element_digest - This argument is a string that specifies the type of +! digest used for the array data to ensure its integrity; +! element_hash - The digest or hash value of the uncompressed array data +! stored in the associated binary file; +! compressor - A string specifying the compression format used. +! compressed_size - The size of the compressed array. +! compressed_hash - The digest/hash value of the compressed array. +! encoder - A string specifying the data encoding format used. +! +!=============================================================================== +! + subroutine XMLAddElementFile(root_ptr, section_name, element_name, & + element_value, element_dtype, element_size, & + element_dims, element_digest, element_hash, & + compressor, compressed_size, compressed_hash, & + encoder) + + implicit none + + type(XMLNode) , pointer , intent(inout) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + character(len=*) , intent(in ) :: element_value, element_dtype + integer(kind=8) , intent(in ) :: element_size + integer, dimension(:) , intent(in ) :: element_dims + character(len=*) , intent(in ) :: element_digest, element_hash + integer(kind=8) , optional, intent(in ) :: compressed_size + character(len=*), optional, intent(in ) :: compressor, compressed_hash, & + encoder + + type(XMLNode) , pointer :: node_ptr, elem_ptr + type(XMLAttribute), pointer :: attr_ptr + + logical :: found + character(len=64) :: str + +!------------------------------------------------------------------------------- +! + found = .false. + node_ptr => root_ptr%children + do while (associated(node_ptr) .and. .not. found) + if (trim(node_ptr%name) == trim(section_name)) then + found = .true. + else + node_ptr => node_ptr%next + end if + end do + + if (.not. found) then + call XMLNodeInit(node_ptr, section_name) + call XMLAddChild(root_ptr, node_ptr) + end if + + call XMLNodeInit(elem_ptr, element_name, element_value) + call XMLAttributeInit(attr_ptr, "type", "string") + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAttributeInit(attr_ptr, "data_type", element_dtype) + call XMLAddAttribute(elem_ptr, attr_ptr) + write(str,"(i0)") element_size + call XMLAttributeInit(attr_ptr, "size", trim(adjustl(str))) + call XMLAddAttribute(elem_ptr, attr_ptr) + write(str,"(8(i0,1x))") element_dims + call XMLAttributeInit(attr_ptr, "dimensions", trim(adjustl(str))) + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAttributeInit(attr_ptr, "digest_type", trim(element_digest)) + call XMLAddAttribute(elem_ptr, attr_ptr) + call XMLAttributeInit(attr_ptr, "digest", trim(element_hash)) + call XMLAddAttribute(elem_ptr, attr_ptr) + if (present(compressor)) then + call XMLAttributeInit(attr_ptr, "compression_format", trim(compressor)) + call XMLAddAttribute(elem_ptr, attr_ptr) + if (present(compressed_size)) then + write(str,"(i0)") compressed_size + call XMLAttributeInit(attr_ptr, "compressed_size", trim(adjustl(str))) + call XMLAddAttribute(elem_ptr, attr_ptr) + end if + if (present(compressed_hash)) then + call XMLAttributeInit(attr_ptr, "compressed_digest", & + trim(compressed_hash)) + call XMLAddAttribute(elem_ptr, attr_ptr) + end if + end if + if (present(encoder)) then + call XMLAttributeInit(attr_ptr, "data_encoder", trim(encoder)) + call XMLAddAttribute(elem_ptr, attr_ptr) + end if + call XMLAddChild(node_ptr, elem_ptr) + +!------------------------------------------------------------------------------- +! + end subroutine XMLAddElementFile + +!=============================================================================== +! +! subroutine XMLGetElementValueDouble: +! ----------------------------------- +! +! Description: +! +! Reads an XML node value and returns it as a double precision number. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLGetElementValueDouble(root_ptr, section_name, & + element_name, element_value) + + use helpers, only : print_message + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + real(kind=8) , intent(inout) :: element_value + + character(len=*), parameter :: loc = "XML::XMLGetElementValueDouble()" + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, 'type', attr_ptr) + + if (associated(attr_ptr)) then + if (trim(attr_ptr%value) == 'double') then + read(node_ptr%value,*) element_value + else + call print_message(loc, "The value of element '" // & + trim(element_name) // & + "' is not a double precision number!") + end if + end if + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetElementValueDouble + +!=============================================================================== +! +! subroutine XMLGetElementValueInteger: +! ------------------------------------ +! +! Description: +! +! Reads an XML node value and returns it as an integer. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLGetElementValueInteger(root_ptr, section_name, & + element_name, element_value) + + use helpers, only : print_message + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + integer , intent(inout) :: element_value + + character(len=*), parameter :: loc = "XML::XMLGetElementValueInteger()" + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, 'type', attr_ptr) + + if (associated(attr_ptr)) then + if (trim(attr_ptr%value) == 'integer') then + read(node_ptr%value,*) element_value + else + call print_message(loc, "The value of element '" // & + trim(element_name) // "' is not an integer!") + end if + end if + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetElementValueInteger + +!=============================================================================== +! +! subroutine XMLGetElementValueString: +! ------------------------------------ +! +! Description: +! +! Reads an XML node value and returns it as a string. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element is located; +! element_name - The name of the XML element; +! element_value - The value of the element; +! +!=============================================================================== +! + subroutine XMLGetElementValueString(root_ptr, section_name, & + element_name, element_value) + + use helpers, only : print_message + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name + character(len=*) , intent(inout) :: element_value + + character(len=*), parameter :: loc = "XML::XMLGetElementValueString()" + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, 'type', attr_ptr) + + if (associated(attr_ptr)) then + if (trim(attr_ptr%value) == 'string') then + read(node_ptr%value,*) element_value + else + call print_message(loc, "The value of element '" // & + trim(element_name) // "' is not a string!") + end if + end if + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetElementValueString + +!=============================================================================== +! +! subroutine XMLHasAttribute: +! -------------------------- +! +! Description: +! +! Verifies whether the XML element contains an attribute specified by its name. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element +! is located; +! element_name - The name of the XML element; +! attribute_name - The name of the attribute whose value is to be retrieved; +! +!=============================================================================== +! + logical function XMLHasAttribute(root_ptr, section_name, element_name, & + attribute_name) result(ret) + + implicit none + + type(XMLNode), pointer, intent(in) :: root_ptr + character(len=*) , intent(in) :: section_name, element_name, & + attribute_name + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + ret = .false. + + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + attr_ptr => node_ptr%attributes + do while (associated(attr_ptr)) + if (trim(attr_ptr%name) == trim(attribute_name)) then + ret = .true. + return + end if + attr_ptr => attr_ptr%next + end do + end if + +!------------------------------------------------------------------------------- +! + end function XMLHasAttribute + +!=============================================================================== +! +! subroutine XMLGetAttributeValueDouble: +! ------------------------------------- +! +! Description: +! +! Retrieves a double precision attribute value from an XML element. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element +! is located; +! element_name - The name of the XML element; +! attribute_name - The name of the attribute whose value is to be retrieved; +! attribute_value - The value of the attribute; +! +!=============================================================================== +! + subroutine XMLGetAttributeValueDouble(root_ptr, section_name, element_name, & + attribute_name, attribute_value) + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name, & + attribute_name + real(kind=8) , intent(inout) :: attribute_value + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, trim(attribute_name), attr_ptr) + + if (associated(attr_ptr)) read(attr_ptr%value, *) attribute_value + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetAttributeValueDouble + +!=============================================================================== +! +! subroutine XMLGetAttributeValueInteger: +! -------------------------------------- +! +! Description: +! +! Retrieves an integer attribute value from an XML element. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element +! is located; +! element_name - The name of the XML element; +! attribute_name - The name of the attribute whose value is to be retrieved; +! attribute_value - The value of the attribute; +! +!=============================================================================== +! + subroutine XMLGetAttributeValueInteger(root_ptr, section_name, element_name, & + attribute_name, attribute_value) + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name, & + attribute_name + integer , intent(inout) :: attribute_value + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, trim(attribute_name), attr_ptr) + + if (associated(attr_ptr)) read(attr_ptr%value, *) attribute_value + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetAttributeValueInteger + +!=============================================================================== +! +! subroutine XMLGetAttributeValueLong: +! ----------------------------------- +! +! Description: +! +! Retrieves a long integer attribute value from an XML element. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element +! is located; +! element_name - The name of the XML element; +! attribute_name - The name of the attribute whose value is to be retrieved; +! attribute_value - The value of the attribute; +! +!=============================================================================== +! + subroutine XMLGetAttributeValueLong(root_ptr, section_name, element_name, & + attribute_name, attribute_value) + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name, & + attribute_name + integer(kind=8) , intent(inout) :: attribute_value + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, trim(attribute_name), attr_ptr) + + if (associated(attr_ptr)) read(attr_ptr%value, *) attribute_value + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetAttributeValueLong + +!=============================================================================== +! +! subroutine XMLGetAttributeValueString: +! ------------------------------------- +! +! Description: +! +! Retrieves a string attribute value from an XML element. +! +! Arguments: +! +! root_ptr - The root node of the XML tree; +! section_name - The section of the XML document where the element +! is located; +! element_name - The name of the XML element; +! attribute_name - The name of the attribute whose value is to be retrieved; +! attribute_value - The value of the attribute; +! +!=============================================================================== +! + subroutine XMLGetAttributeValueString(root_ptr, section_name, element_name, & + attribute_name, attribute_value) + + implicit none + + type(XMLNode), pointer, intent(in ) :: root_ptr + character(len=*) , intent(in ) :: section_name, element_name, & + attribute_name + character(len=*) , intent(inout) :: attribute_value + + type(XMLNode) , pointer :: node_ptr + type(XMLAttribute), pointer :: attr_ptr + +!------------------------------------------------------------------------------- +! + call XMLFindElement(root_ptr, section_name, element_name, node_ptr) + + if (associated(node_ptr)) then + call XMLGetAttribute(node_ptr, trim(attribute_name), attr_ptr) + + if (associated(attr_ptr)) read(attr_ptr%value, *) attribute_value + end if + +!------------------------------------------------------------------------------- +! + end subroutine XMLGetAttributeValueString + +end module XML