1071 lines
33 KiB
Fortran
1071 lines
33 KiB
Fortran
!!******************************************************************************
|
|
!!
|
|
!! This file is part of the AMUN source code, a program to perform
|
|
!! Newtonian or relativistic magnetohydrodynamical simulations on uniform or
|
|
!! adaptive mesh.
|
|
!!
|
|
!! Copyright (C) 2020-2023 Grzegorz Kowal <grzegorz@amuncode.org>
|
|
!!
|
|
!! 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 <http://www.gnu.org/licenses/>.
|
|
!!
|
|
!!******************************************************************************
|
|
!!
|
|
!! module: COMPRESSION
|
|
!!
|
|
!! This module provides compression for the XML-binary format.
|
|
!!
|
|
!!******************************************************************************
|
|
!
|
|
module compression
|
|
|
|
use iso_c_binding
|
|
use iso_fortran_env
|
|
|
|
implicit none
|
|
|
|
! interfaces to compression algorithms
|
|
!
|
|
#ifdef ZSTD
|
|
interface
|
|
|
|
integer(c_size_t) function zstd_bound(srcSize) &
|
|
bind(C, name="ZSTD_compressBound")
|
|
use iso_c_binding, only: c_size_t
|
|
implicit none
|
|
integer(c_size_t), value :: srcSize
|
|
end function zstd_bound
|
|
|
|
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
|
|
type(c_ptr) , value :: src, dst
|
|
integer(c_size_t), value :: srcSize, dstCapacity
|
|
integer(c_int) , value :: level
|
|
end function zstd_compress
|
|
|
|
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
|
|
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(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(c_size_t), value :: srcSize
|
|
type(c_ptr) , value :: preferencesPtr
|
|
end function lz4_bound
|
|
|
|
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(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_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_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 */
|
|
|
|
#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 :: compressor_unkn = -1
|
|
enumerator :: compressor_none = 0
|
|
enumerator :: compressor_zstd
|
|
enumerator :: compressor_lz4
|
|
enumerator :: compressor_lzma
|
|
end enum
|
|
|
|
! supported data encoders
|
|
!
|
|
enum, bind(c)
|
|
enumerator :: encoder_unkn = -1
|
|
enumerator :: encoder_none = 0
|
|
enumerator :: encoder_shuffle
|
|
enumerator :: encoder_bytedelta
|
|
end enum
|
|
|
|
private
|
|
|
|
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
|
|
|
|
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
!
|
|
contains
|
|
!
|
|
!===============================================================================
|
|
!!
|
|
!!*** PUBLIC SUBROUTINES ****************************************************
|
|
!!
|
|
!===============================================================================
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine CHECK_COMPRESSOR:
|
|
! ---------------------------
|
|
!
|
|
! Subroutine sets the compressor ID and the compression level based on
|
|
! the compressor name.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! compressor_name - the compressor name;
|
|
! compressor_id - the compressor ID;
|
|
! compression_level - the compression level;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
subroutine check_compressor(compressor_name, compressor_id, &
|
|
compression_level)
|
|
|
|
implicit none
|
|
|
|
character(len=*) , intent(in ) :: compressor_name
|
|
integer , intent( out) :: compressor_id
|
|
integer , intent(inout) :: compression_level
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(trim(adjustl(compressor_name)))
|
|
#ifdef ZSTD
|
|
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", "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")
|
|
compressor_id = compressor_lzma
|
|
if (compression_level < 0 .or. &
|
|
compression_level > 9) compression_level = 6
|
|
#endif /* LZMA */
|
|
case default
|
|
compressor_id = compressor_none
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end subroutine check_compressor
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! function IS_COMPRESSOR_ON:
|
|
! -------------------------
|
|
!
|
|
! The function determines if any compression is used.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! compressor_id - the compressor ID;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
logical function is_compressor_on(compressor_id)
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: compressor_id
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
is_compressor_on = compressor_id /= compressor_none
|
|
return
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
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 size of the buffer required to compress data.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! compressor_id - the compressor ID;
|
|
! level - the compression level;
|
|
! uncompressed_bytes - the length of the uncompressed sequence of bytes;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
integer(c_size_t) function compression_bound(compressor_id, level, &
|
|
uncompressed_bytes)
|
|
|
|
implicit none
|
|
|
|
integer , intent(in) :: compressor_id, level
|
|
integer(c_size_t), intent(in) :: uncompressed_bytes
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(compressor_id)
|
|
#ifdef ZSTD
|
|
case(compressor_zstd)
|
|
compression_bound = zstd_bound(uncompressed_bytes)
|
|
#endif /* ZSTD */
|
|
#ifdef LZ4
|
|
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 = uncompressed_bytes
|
|
end select
|
|
|
|
return
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end function compression_bound
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine COMPRESS:
|
|
! -------------------
|
|
!
|
|
! Subroutine compresses the input buffer.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! 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(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
|
|
|
|
integer(c_size_t), target :: bytes
|
|
integer(c_int) :: ret
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(compressor_id)
|
|
#ifdef ZSTD
|
|
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(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(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
|
|
write(error_unit,"(a,i0,a)") "LZMA: Unknown error (", ret, ")."
|
|
clen = 0_8
|
|
end if
|
|
#endif /* LZMA */
|
|
case default
|
|
clen = 0_8
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end subroutine compress
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! 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:
|
|
! -----------------
|
|
!
|
|
! Subroutine encodes the input buffer for better data compression.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! 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(encoder_id, item_size, bytes, input_ptr, output)
|
|
|
|
use iso_c_binding, only : c_ptr, c_f_pointer
|
|
|
|
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
|
|
|
|
integer(kind=1), dimension(:), pointer :: input
|
|
|
|
integer(kind=8) :: i, j, m, n, item_count
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
call c_f_pointer(input_ptr, input, [ bytes ])
|
|
|
|
select case(encoder_id)
|
|
case(encoder_shuffle)
|
|
item_count = bytes / item_size
|
|
|
|
i = 1
|
|
j = item_count
|
|
do m = 1, item_size
|
|
output(i:j) = input(m:bytes:item_size)
|
|
|
|
i = j + 1
|
|
j = j + item_count
|
|
end do
|
|
|
|
case(encoder_bytedelta)
|
|
item_count = bytes / item_size
|
|
|
|
i = 1
|
|
j = item_count
|
|
do m = 1, item_size
|
|
output(i:j) = input(m:bytes:item_size)
|
|
|
|
do n = j, i + 1, -1
|
|
output(n) = output(n) - output(n-1)
|
|
end do
|
|
|
|
i = j + 1
|
|
j = j + item_count
|
|
end do
|
|
|
|
case default
|
|
output(:) = input(:)
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
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
|
|
|
|
!===============================================================================
|
|
!
|
|
end module compression
|