345 lines
10 KiB
Fortran
345 lines
10 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-2021 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
|
|
|
|
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(kind=c_size_t), value :: srcSize
|
|
end function zstd_bound
|
|
|
|
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
|
|
end function zstd_compress
|
|
|
|
integer function zstd_iserror(code) bind(C, name="ZSTD_isError")
|
|
use iso_c_binding, only: c_size_t
|
|
implicit none
|
|
integer(kind=c_size_t), value :: code
|
|
end function zstd_iserror
|
|
|
|
end interface
|
|
#endif /* ZSTD */
|
|
#ifdef LZ4
|
|
interface
|
|
|
|
integer(kind=c_size_t) function lz4_bound(srcSize, prefsPtr) &
|
|
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
|
|
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 function lz4_iserror(code) bind(C, name="LZ4F_isError")
|
|
use iso_c_binding, only: c_size_t
|
|
implicit none
|
|
integer(kind=c_size_t), value :: code
|
|
end function lz4_iserror
|
|
|
|
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
|
|
implicit none
|
|
integer(c_int) , value :: preset, check
|
|
integer(kind=c_size_t), value :: srcSize, dstCapacity
|
|
type(c_ptr) , value :: allocator, src, dst, dstPos
|
|
end function lzma_compress
|
|
|
|
end interface
|
|
#endif /* LZMA */
|
|
|
|
! supported compression formats
|
|
!
|
|
enum, bind(c)
|
|
enumerator compression_none
|
|
enumerator compression_zstd
|
|
enumerator compression_lz4
|
|
enumerator compression_lzma
|
|
end enum
|
|
|
|
! compression parameters
|
|
!
|
|
integer(kind(compression_none)), save :: compression_format = 0
|
|
integer , save :: compression_level = 0
|
|
character(len=4) , save :: compression_suffix = ''
|
|
|
|
private
|
|
|
|
public :: set_compression, get_compression, compression_bound, compress
|
|
public :: compression_suffix
|
|
|
|
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
!
|
|
contains
|
|
!
|
|
!===============================================================================
|
|
!!
|
|
!!*** PUBLIC SUBROUTINES ****************************************************
|
|
!!
|
|
!===============================================================================
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine SET_COMPRESSION:
|
|
! --------------------------
|
|
!
|
|
! Subroutine sets the compression format and level.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! cformat - the compression format string;
|
|
! clevel - the compression level;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
subroutine set_compression(cformat, clevel)
|
|
|
|
implicit none
|
|
|
|
character(len=*) , intent(inout) :: cformat
|
|
integer , intent(in) :: clevel
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(trim(adjustl(cformat)))
|
|
#ifdef ZSTD
|
|
case("zstd", "ZSTD", "zst", "ZST", "Zstandard")
|
|
cformat = "zstd"
|
|
compression_format = compression_zstd
|
|
compression_level = max(0, min(19, clevel))
|
|
compression_suffix = ".zst"
|
|
#endif /* ZSTD */
|
|
#ifdef LZ4
|
|
case("lz4", "LZ4")
|
|
cformat = "lz4"
|
|
compression_format = compression_lz4
|
|
compression_level = max(1, min(12, clevel))
|
|
compression_suffix = ".lz4"
|
|
#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"
|
|
#endif /* LZMA */
|
|
case default
|
|
cformat = "none"
|
|
compression_format = compression_none
|
|
compression_level = clevel
|
|
compression_suffix = ""
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end subroutine set_compression
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! function GET_COMPRESSION:
|
|
! ------------------------
|
|
!
|
|
! Function returns the compression format index.
|
|
!
|
|
!
|
|
!===============================================================================
|
|
!
|
|
integer function get_compression()
|
|
|
|
implicit none
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
get_compression = compression_format
|
|
return
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end function get_compression
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! function COMPRESSION_BOUND:
|
|
! --------------------------
|
|
!
|
|
! Function returns the minimum buffer size required to perform
|
|
! the compression.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! ilen - the length of the sequence of bytes to compress;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
integer(kind=8) function compression_bound(ilen)
|
|
|
|
use iso_c_binding, only: c_loc
|
|
|
|
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 */
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(compression_format)
|
|
#ifdef ZSTD
|
|
case(compression_zstd)
|
|
compression_bound = zstd_bound(ilen)
|
|
#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))
|
|
#endif /* LZ4 */
|
|
case default
|
|
compression_bound = ilen
|
|
end select
|
|
|
|
return
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end function compression_bound
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine COMPRESS:
|
|
! -------------------
|
|
!
|
|
! Subroutine compressed input buffer using ZSTD 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;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
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 */
|
|
|
|
implicit none
|
|
|
|
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 */
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
select case(compression_format)
|
|
#ifdef ZSTD
|
|
case(compression_zstd)
|
|
clen = zstd_compress(buffer, clen, input, ilen, compression_level)
|
|
if (zstd_iserror(clen) /= 0) clen = 0
|
|
#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
|
|
#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
|
|
else
|
|
clen = lsize
|
|
end if
|
|
#endif /* LZMA */
|
|
case default
|
|
clen = 0
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end subroutine compress
|
|
|
|
!===============================================================================
|
|
!
|
|
end module compression
|