amun-code/sources/compression.F90

!!******************************************************************************
!!
!!  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_int) function zstd_compress(obuf, osize, ibuf, isize, lev)       &
                                            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 :: osize, isize
      type(c_ptr), value :: obuf, ibuf
      integer(kind=c_int), value :: lev
    end function zstd_compress
  end interface
#endif /* ZSTD */
#ifdef LZ4
  interface
    integer(c_int) function lz4_compress(src, dst, srcSize, dstCapacity)       &
                                           bind(C, name="LZ4_compress_default")
      use iso_c_binding, only: c_int, c_ptr
      implicit none
      type(c_ptr), value :: src, dst
      integer(kind=c_int), value :: srcSize, dstCapacity
    end function lz4_compress
    integer(c_int) function lz4_compressBound(srcSize)                         &
                                           bind(C, name="LZ4_compressBound")
      use iso_c_binding, only: c_int
      implicit none
      integer(kind=c_int), value :: srcSize
    end function lz4_compressBound
  end interface
#endif /* LZ4 */

! 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

! 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  = 0
      suffix             = ".lz4"
#endif /* LZ4 */
    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

    implicit none

! subroutine arguments
!
    integer(kind=1), dimension(:), target, intent(in)  :: input
    integer(kind=1), dimension(:), target, intent(out) :: output
    integer(kind=8)                      , intent(out) :: csize

! compression buffer
!
    integer(kind=1), dimension(:), allocatable, target :: buffer

!-------------------------------------------------------------------------------
!
    csize = min(size(input), size(output))
    select case(compression_format)
#ifdef ZSTD
    case(compression_zstd)
      csize = zstd_compress(c_loc(output), sizeof(output),                     &
                            c_loc(input), sizeof(input), compression_level)
#endif /* ZSTD */
#ifdef LZ4
    case(compression_lz4)
      allocate(buffer(lz4_compressBound(size(input))))
      csize = lz4_compress(c_loc(input), c_loc(buffer),                        &
                           size(input), size(buffer))
      if (csize > 0 .and. csize <= size(output) - 4) then
        output(1:4) = transfer(1_4 * size(input), [1_1])
        output(5:csize+4) = buffer(1:csize)
        csize = csize + 4
      else
        csize = -1
      end if
      deallocate(buffer)
#endif /* LZ4 */
    case default
      output(1:csize) = input(1:csize)
    end select

!-------------------------------------------------------------------------------
!
  end subroutine compress

!===============================================================================
!
end module compression