!!****************************************************************************** !! !! 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 !! !! 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 . !! !!****************************************************************************** !! !! 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