312 lines
9.7 KiB
Fortran
312 lines
9.7 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 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
|
|
|
|
! module variables are not implicit by default
|
|
!
|
|
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
|
|
|
|
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
|
|
|
|
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 */
|
|
|
|
! compression parameters
|
|
!
|
|
integer, save :: compression_format = 0
|
|
integer, save :: compression_level = 0
|
|
|
|
! supported compression formats
|
|
!
|
|
integer, parameter :: compression_none = 0
|
|
integer, parameter :: compression_zstd = 1
|
|
integer, parameter :: compression_lz4 = 2
|
|
integer, parameter :: compression_lzma = 3
|
|
|
|
! by default everything is private
|
|
!
|
|
private
|
|
|
|
! declare public subroutines
|
|
!
|
|
public :: set_compression, get_compression, compress
|
|
|
|
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
!
|
|
contains
|
|
!
|
|
!===============================================================================
|
|
!!
|
|
!!*** PUBLIC SUBROUTINES ****************************************************
|
|
!!
|
|
!===============================================================================
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine SET_COMPRESSION:
|
|
! --------------------------
|
|
!
|
|
! Subroutine sets the compression format and level.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! cformat - the compression format string;
|
|
! clevel - the compression level;
|
|
! suffix - the compressed file suffix;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
subroutine set_compression(cformat, clevel, suffix)
|
|
|
|
implicit none
|
|
|
|
! subroutine arguments
|
|
!
|
|
character(len=*) , intent(inout) :: cformat
|
|
integer , intent(in) :: clevel
|
|
character(len=8) , intent(out) :: suffix
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
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))
|
|
suffix = ".zst"
|
|
#endif /* ZSTD */
|
|
#ifdef LZ4
|
|
case("lz4", "LZ4")
|
|
cformat = "lz4"
|
|
compression_format = compression_lz4
|
|
compression_level = max(1, min(12, clevel))
|
|
suffix = ".lz4"
|
|
#endif /* LZ4 */
|
|
#ifdef LZMA
|
|
case("lzma", "LZMA", "xz", "XZ")
|
|
cformat = "lzma"
|
|
compression_format = compression_lzma
|
|
compression_level = max(0, min(9, clevel))
|
|
suffix = ".xz"
|
|
#endif /* LZMA */
|
|
case default
|
|
cformat = "none"
|
|
compression_format = compression_none
|
|
compression_level = clevel
|
|
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
|
|
!
|
|
!===============================================================================
|
|
!
|
|
! subroutine COMPRESS:
|
|
! -------------------
|
|
!
|
|
! Subroutine compressed input buffer using ZSTD compression.
|
|
!
|
|
! Arguments:
|
|
!
|
|
! input - the input sequence of bytes;
|
|
!
|
|
!===============================================================================
|
|
!
|
|
subroutine compress(input, output, csize)
|
|
|
|
use iso_c_binding, only: c_int, c_loc
|
|
#ifdef LZ4
|
|
use iso_c_binding, only: c_null_ptr
|
|
#endif /* LZ4 */
|
|
|
|
implicit none
|
|
|
|
! subroutine arguments
|
|
!
|
|
integer(kind=1), dimension(:), target, intent(in) :: input
|
|
integer(kind=1), dimension(:), target, intent(out) :: output
|
|
integer(kind=8) , target, intent(out) :: csize
|
|
|
|
#ifdef LZ4
|
|
! preferences
|
|
!
|
|
integer, dimension(14), target :: prefs = [5, 0, 1, 0, 0, 0, 0, 0, &
|
|
0, 0, 0, 0, 0, 0]
|
|
#endif /* LZ4 */
|
|
#ifdef LZMA
|
|
! return value
|
|
!
|
|
integer :: ret
|
|
#endif /* LZMA */
|
|
|
|
! compression buffer
|
|
!
|
|
integer(kind=1), dimension(:), allocatable, target :: buffer
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
csize = min(size(input), size(output))
|
|
select case(compression_format)
|
|
#ifdef ZSTD
|
|
case(compression_zstd)
|
|
allocate(buffer(zstd_bound(size(input, kind=8))))
|
|
csize = zstd_compress(c_loc(buffer), size(buffer, kind=8), &
|
|
c_loc(input), size(input, kind=8), &
|
|
compression_level)
|
|
if (csize > 0 .and. csize <= size(output, kind=8)) then
|
|
output(1:csize) = buffer(1:csize)
|
|
else
|
|
csize = -1
|
|
end if
|
|
deallocate(buffer)
|
|
#endif /* ZSTD */
|
|
#ifdef LZ4
|
|
case(compression_lz4)
|
|
prefs(5:6) = transfer(size(input, kind=8), [ 0_4 ])
|
|
prefs(9) = compression_level
|
|
allocate(buffer(lz4_bound(size(input, kind=8), c_loc(prefs))))
|
|
csize = lz4_compress(c_loc(buffer), size(buffer, kind=8), &
|
|
c_loc(input), size(input, kind=8), c_loc(prefs))
|
|
if (csize > 0 .and. csize <= size(output, kind=8)) then
|
|
output(1:csize) = buffer(1:csize)
|
|
else
|
|
csize = -1
|
|
end if
|
|
deallocate(buffer)
|
|
#endif /* LZ4 */
|
|
#ifdef LZMA
|
|
case(compression_lzma)
|
|
csize = 0
|
|
allocate(buffer(size(input)))
|
|
ret = lzma_compress(compression_level, 4, c_null_ptr, &
|
|
c_loc(input), size(input, kind=8), &
|
|
c_loc(buffer), c_loc(csize), size(buffer, kind=8))
|
|
if (ret == 0 .and. csize <= size(output, kind=8)) then
|
|
output(1:csize) = buffer(1:csize)
|
|
else
|
|
csize = -1
|
|
end if
|
|
deallocate(buffer)
|
|
#endif /* LZMA */
|
|
case default
|
|
output(1:csize) = input(1:csize)
|
|
end select
|
|
|
|
!-------------------------------------------------------------------------------
|
|
!
|
|
end subroutine compress
|
|
|
|
!===============================================================================
|
|
!
|
|
end module compression
|