From 20282539f9600cbcf5832683589dd86a6bcbb558 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 28 Nov 2021 09:59:20 -0300 Subject: [PATCH 01/25] COMPRESSION: Use ENUM to enumerate compression formats. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index 081cfe5..5ff8e99 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -94,17 +94,19 @@ module compression 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 + 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 private From e6fc8e5d24ba505fc674aae29c8f7fe397a6e5d6 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 28 Nov 2021 22:19:50 -0300 Subject: [PATCH 02/25] COMPRESSION: Pass the input length to compress(). Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 30 +++++++++++++++++------------- sources/io.F90 | 2 +- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index 5ff8e99..50e8984 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -212,11 +212,14 @@ module compression ! ! Arguments: ! -! input - the input sequence of bytes; +! input - the input sequence of bytes; +! ilen - the length of input; +! output - the compressed sequence of bytes; +! csize - the length of compressed sequence; ! !=============================================================================== ! - subroutine compress(input, output, csize) + subroutine compress(input, ilen, output, csize) use iso_c_binding, only: c_int, c_loc #ifdef LZ4 @@ -226,6 +229,7 @@ module compression implicit none integer(kind=1), dimension(:), target, intent(in) :: input + integer(kind=8) , intent(in) :: ilen integer(kind=1), dimension(:), target, intent(out) :: output integer(kind=8) , target, intent(out) :: csize @@ -241,13 +245,13 @@ module compression !------------------------------------------------------------------------------- ! - csize = min(size(input, kind=8), size(output, kind=8)) + csize = min(ilen, size(output, kind=8)) 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), & + allocate(buffer(zstd_bound(ilen))) + csize = zstd_compress(c_loc(buffer), size(buffer, kind=8), & + c_loc(input), ilen, & compression_level) if (csize > 0 .and. csize <= size(output, kind=8)) then output(1:csize) = buffer(1:csize) @@ -258,11 +262,11 @@ module compression #endif /* ZSTD */ #ifdef LZ4 case(compression_lz4) - prefs(5:6) = transfer(size(input, kind=8), [ 0_4 ]) + prefs(5:6) = transfer(ilen, [ 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)) + allocate(buffer(lz4_bound(ilen, c_loc(prefs)))) + csize = lz4_compress(c_loc(buffer), size(buffer, kind=8), & + c_loc(input), ilen, c_loc(prefs)) if (csize > 0 .and. csize <= size(output, kind=8)) then output(1:csize) = buffer(1:csize) else @@ -273,9 +277,9 @@ module compression #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), & + allocate(buffer(ilen)) + ret = lzma_compress(compression_level, 4, c_null_ptr, & + c_loc(input), ilen, & 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) diff --git a/sources/io.F90 b/sources/io.F90 index a9e3ec6..9298ddd 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -2843,7 +2843,7 @@ module io if (present(compressed_bytes) .and. get_compression() > 0) then allocate(buffer(array_bytes), stat = status) if (status == 0) then - call compress(array, buffer, compressed_bytes) + call compress(array, array_bytes, buffer, compressed_bytes) if (compressed_bytes > 0) then open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream', status = 'replace') From e4ffa6271485a6b0d2ee8afd715a239db8eaf8d9 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 28 Nov 2021 22:32:51 -0300 Subject: [PATCH 03/25] COMPRESSION: Add function to determine the compression buffer size. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 52 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index 50e8984..2923ac3 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -110,7 +110,7 @@ module compression private - public :: set_compression, get_compression, compress + public :: set_compression, get_compression, compression_bound, compress !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -205,6 +205,56 @@ module 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: ! ------------------- ! From 9ddf7c7b4425584266767358237ed83aaf6dbc30 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 28 Nov 2021 22:38:30 -0300 Subject: [PATCH 04/25] IO: Use compression_bound() to determine the buffer size. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 9298ddd..407f961 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -2806,7 +2806,7 @@ module io array_bytes, array_digest, & compressed_bytes, compressed_digest) - use compression, only : get_compression, compress + use compression, only : get_compression, compression_bound, compress use hash , only : get_hash implicit none @@ -2841,10 +2841,11 @@ module io ! try to compress array and write it ! if (present(compressed_bytes) .and. get_compression() > 0) then - allocate(buffer(array_bytes), stat = status) + compressed_bytes = compression_bound(array_bytes) + allocate(buffer(compressed_bytes), stat = status) if (status == 0) then call compress(array, array_bytes, buffer, compressed_bytes) - if (compressed_bytes > 0) then + if (compressed_bytes < array_bytes) then open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream', status = 'replace') write(lun) buffer(1:compressed_bytes) From 88cdf230782469115ab0d28606bf3e342d096ed3 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 28 Nov 2021 23:27:03 -0300 Subject: [PATCH 05/25] COMPRESSION, IO: Remove double buffer for compression. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 81 ++++++++++++++++++----------------------- sources/io.F90 | 28 +++++++++----- 2 files changed, 54 insertions(+), 55 deletions(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index 2923ac3..c479a33 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -36,15 +36,15 @@ module compression #ifdef ZSTD interface - integer(c_size_t) function zstd_bound(srcSize) & + 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) & + 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 @@ -53,6 +53,12 @@ module compression 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 @@ -75,6 +81,12 @@ module compression 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 @@ -264,82 +276,61 @@ module compression ! ! input - the input sequence of bytes; ! ilen - the length of input; -! output - the compressed sequence of bytes; -! csize - the length of compressed sequence; +! buffer - the compressed sequence of bytes; +! clen - the length of buffer in bytes; once the compression was +! successful, it returns the length of the compressed stream; ! !=============================================================================== ! - subroutine compress(input, ilen, output, csize) + subroutine compress(input, ilen, buffer, clen) - use iso_c_binding, only: c_int, c_loc + use iso_c_binding, only : c_int, c_loc, c_ptr #ifdef LZ4 - use iso_c_binding, only: c_null_ptr + use iso_c_binding, only : c_null_ptr #endif /* LZ4 */ implicit none - integer(kind=1), dimension(:), target, intent(in) :: input - integer(kind=8) , intent(in) :: ilen - integer(kind=1), dimension(:), target, intent(out) :: output - integer(kind=8) , target, intent(out) :: csize + 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 :: ret + integer(kind=8), target :: lsize + integer :: ret #endif /* LZMA */ - integer(kind=1), dimension(:), allocatable, target :: buffer - !------------------------------------------------------------------------------- ! - csize = min(ilen, size(output, kind=8)) select case(compression_format) #ifdef ZSTD case(compression_zstd) - allocate(buffer(zstd_bound(ilen))) - csize = zstd_compress(c_loc(buffer), size(buffer, kind=8), & - c_loc(input), ilen, & - 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) + 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 - allocate(buffer(lz4_bound(ilen, c_loc(prefs)))) - csize = lz4_compress(c_loc(buffer), size(buffer, kind=8), & - c_loc(input), ilen, 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) + clen = lz4_compress(buffer, clen, input, ilen, c_loc(prefs)) + if (lz4_iserror(clen) /= 0) clen = 0 #endif /* LZ4 */ #ifdef LZMA case(compression_lzma) - csize = 0 - allocate(buffer(ilen)) + lsize = 0 ret = lzma_compress(compression_level, 4, c_null_ptr, & - c_loc(input), ilen, & - 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) + input, ilen, buffer, c_loc(lsize), clen) + if (ret > 0) then + clen = 0 else - csize = -1 + clen = lsize end if - deallocate(buffer) #endif /* LZMA */ - case default - output(1:csize) = input(1:csize) end select !------------------------------------------------------------------------------- diff --git a/sources/io.F90 b/sources/io.F90 index 407f961..42b8cda 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -2806,18 +2806,21 @@ module io array_bytes, array_digest, & compressed_bytes, compressed_digest) - use compression, only : get_compression, compression_bound, compress - use hash , only : get_hash + use compression , only : get_compression, compression_bound, compress + use hash , only : get_hash + use iso_c_binding, only : c_ptr, c_loc implicit none ! input and output arguments ! - character(len=*) , intent(in) :: path, name - integer(kind=1), dimension(:), intent(in) :: array - integer , intent(in) :: hash_type - integer(kind=8), optional , intent(out) :: array_bytes, compressed_bytes - integer(kind=8), optional , intent(out) :: array_digest, compressed_digest + character(len=*) , intent(in) :: path, name + integer(kind=1), dimension(:), target, intent(in) :: array + integer , intent(in) :: hash_type + integer(kind=8), optional , intent(out) :: array_bytes + integer(kind=8), optional , intent(out) :: compressed_bytes + integer(kind=8), optional , intent(out) :: array_digest + integer(kind=8), optional , intent(out) :: compressed_digest ! local variables ! @@ -2828,7 +2831,8 @@ module io ! compression buffer ! - integer(kind=1), dimension(:), allocatable :: buffer + integer(kind=1), dimension(:), allocatable, target :: buffer + type(c_ptr) :: buffer_ptr ! !------------------------------------------------------------------------------- ! @@ -2843,9 +2847,10 @@ module io if (present(compressed_bytes) .and. get_compression() > 0) then compressed_bytes = compression_bound(array_bytes) allocate(buffer(compressed_bytes), stat = status) + buffer_ptr = c_loc(buffer) if (status == 0) then - call compress(array, array_bytes, buffer, compressed_bytes) - if (compressed_bytes < array_bytes) then + call compress(c_loc(array), array_bytes, buffer_ptr, compressed_bytes) + if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream', status = 'replace') write(lun) buffer(1:compressed_bytes) @@ -2853,6 +2858,9 @@ module io written = .true. if (present(compressed_digest)) & compressed_digest = get_hash(buffer(1:compressed_bytes), hash_type) + else + compressed_bytes = 0 + compressed_digest = 0 end if deallocate(buffer) end if From de81332cf80654fd02f95012dce7d2c611826bc7 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 29 Nov 2021 08:27:21 -0300 Subject: [PATCH 06/25] COMPRESSION: Reset clen in case the compression is unsupported. This will indicate that no compression should be used. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index c479a33..8fc1632 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -274,9 +274,9 @@ module compression ! ! Arguments: ! -! input - the input sequence of bytes; +! input - the pointer to the input sequence of bytes; ! ilen - the length of input; -! buffer - the compressed sequence of bytes; +! 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; ! @@ -297,7 +297,7 @@ module compression integer(kind=8), intent(inout) :: clen #ifdef LZ4 - integer, dimension(14), target :: prefs = [5, 0, 1, 0, 0, 0, 0, 0, & + integer, dimension(14), target :: prefs = [5, 0, 1, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0] #endif /* LZ4 */ #ifdef LZMA @@ -331,6 +331,8 @@ module compression clen = lsize end if #endif /* LZMA */ + case default + clen = 0 end select !------------------------------------------------------------------------------- From b10b49c8c39c60473163e785932a03cfd2a7566a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 29 Nov 2021 12:08:42 -0300 Subject: [PATCH 07/25] COMPRESSION: Add compression_suffix to store the file extension. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/sources/compression.F90 b/sources/compression.F90 index 8fc1632..eba6671 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -119,10 +119,12 @@ module compression ! 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 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -165,6 +167,7 @@ module compression cformat = "zstd" compression_format = compression_zstd compression_level = max(0, min(19, clevel)) + compression_suffix = ".zst" suffix = ".zst" #endif /* ZSTD */ #ifdef LZ4 @@ -172,6 +175,7 @@ module compression cformat = "lz4" compression_format = compression_lz4 compression_level = max(1, min(12, clevel)) + compression_suffix = ".lz4" suffix = ".lz4" #endif /* LZ4 */ #ifdef LZMA @@ -179,12 +183,14 @@ module compression cformat = "lzma" compression_format = compression_lzma compression_level = max(0, min(9, clevel)) + compression_suffix = ".xz" suffix = ".xz" #endif /* LZMA */ case default cformat = "none" compression_format = compression_none compression_level = clevel + compression_suffix = "" suffix = "" end select From 1fd1ee7602666a358057bda8df8416ee96e13692 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 29 Nov 2021 12:23:26 -0300 Subject: [PATCH 08/25] IO: Add compression suffix to files individually. Signed-off-by: Grzegorz Kowal --- sources/compression.F90 | 8 +----- sources/io.F90 | 62 +++++++++++++++-------------------------- 2 files changed, 23 insertions(+), 47 deletions(-) diff --git a/sources/compression.F90 b/sources/compression.F90 index eba6671..967022f 100644 --- a/sources/compression.F90 +++ b/sources/compression.F90 @@ -147,17 +147,15 @@ module compression ! ! cformat - the compression format string; ! clevel - the compression level; -! suffix - the compressed file suffix; ! !=============================================================================== ! - subroutine set_compression(cformat, clevel, suffix) + subroutine set_compression(cformat, clevel) implicit none character(len=*) , intent(inout) :: cformat integer , intent(in) :: clevel - character(len=8) , intent(out) :: suffix !------------------------------------------------------------------------------- ! @@ -168,7 +166,6 @@ module compression compression_format = compression_zstd compression_level = max(0, min(19, clevel)) compression_suffix = ".zst" - suffix = ".zst" #endif /* ZSTD */ #ifdef LZ4 case("lz4", "LZ4") @@ -176,7 +173,6 @@ module compression compression_format = compression_lz4 compression_level = max(1, min(12, clevel)) compression_suffix = ".lz4" - suffix = ".lz4" #endif /* LZ4 */ #ifdef LZMA case("lzma", "LZMA", "xz", "XZ") @@ -184,14 +180,12 @@ module compression compression_format = compression_lzma compression_level = max(0, min(9, clevel)) compression_suffix = ".xz" - suffix = ".xz" #endif /* LZMA */ case default cformat = "none" compression_format = compression_none compression_level = clevel compression_suffix = "" - suffix = "" end select !------------------------------------------------------------------------------- diff --git a/sources/io.F90 b/sources/io.F90 index 42b8cda..bf9a458 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -116,10 +116,6 @@ module io character(len=255), save :: cformat = "none" ! compression format integer , save :: clevel = 3 ! compression level -! the suffix of binary files in the XML+binary format -! - character(len=8) , save :: binary_file_suffix = ".bin" - ! the type of digest to use ! integer , save :: hash_type = 1 @@ -198,7 +194,6 @@ module io character(len=255) :: precise = "off" character(len=255) :: ghosts = "on" character(len=255) :: xdmf = "off" - character(len=255) :: suffix = "" ! compression file suffix character(len=8) :: dtype = "xxh64" #ifdef HDF5 logical :: cmpstatus = .false. @@ -279,9 +274,7 @@ module io call get_parameter("compression_format", cformat) call get_parameter("compression_level" , clevel) - call set_compression(cformat, clevel, suffix) - if (get_compression() > 0) & - binary_file_suffix = ".bin" // trim(adjustl(suffix)) + call set_compression(cformat, clevel) call get_parameter("digest_type", dtype) select case(dtype) @@ -2467,13 +2460,13 @@ module io pmeta => pmeta%next end do - write(fname,"(a,a)") "metablock_fields", trim(binary_file_suffix) + write(fname,"(a,'.bin')") "metablock_fields" call write_binary_xml(dname, fname, transfer(fields, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) call write_attribute_xml(lun, "fields", fname, hash_str, & dbytes, ddigest, cbytes, cdigest) - write(fname,"(a,a)") "metablock_bounds", trim(binary_file_suffix) + write(fname,"(a,'.bin')") "metablock_bounds" call write_binary_xml(dname, fname, transfer(bounds, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) call write_attribute_xml(lun, "bounds", fname, hash_str, & @@ -2532,8 +2525,7 @@ module io pdata => pdata%next end do ! data blocks - write(fname,"(a,'_',a,'_',i6.6,a)") "datablock", "ids", & - nproc, trim(binary_file_suffix) + write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc call write_binary_xml(dname, fname, transfer(ids, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) call write_attribute_xml(lun, "ids", fname, hash_str, & @@ -2550,8 +2542,8 @@ module io pdata => pdata%next end do - write(fname,"(a,'_',a,'_',i6.6,a)") "datablock", trim(pvars(p)), & - nproc, trim(binary_file_suffix) + write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", & + trim(pvars(p)), nproc call write_binary_xml(dname, fname, & transfer(array(:,:,:,:), [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) @@ -2732,22 +2724,19 @@ module io hash_string, data_bytes, data_digest, & compressed_bytes, compressed_digest) + use compression, only : compression_suffix + implicit none -! input and output arguments -! integer , intent(in) :: lun character(len=*) , intent(in) :: aname, filename, hash_string integer(kind=8) , intent(in) :: data_bytes, data_digest integer(kind=8) , optional, intent(in) :: compressed_bytes, compressed_digest -! local variables -! character(len=256) :: fname character(len=32) :: digest_string, bytes_string character(len=1024) :: string - integer :: l -! + !------------------------------------------------------------------------------- ! fname = filename @@ -2759,6 +2748,7 @@ module io string = trim(string) // ' digest="' // trim(adjustl(digest_string)) // '"' if (present(compressed_bytes)) then if (compressed_bytes > 0) then + fname = trim(fname) // trim(compression_suffix) write(bytes_string,"(1i32)") compressed_bytes string = trim(string) // & ' compression_format="' // trim(adjustl(cformat)) // '"' // & @@ -2770,9 +2760,6 @@ module io trim(adjustl(digest_string)) // '"' end if end if - else - l = index(fname, '.bin') + 3 - fname = filename(1:l) end if end if string = trim(string) // '>' // trim(adjustl(fname)) // '' @@ -2807,13 +2794,12 @@ module io compressed_bytes, compressed_digest) use compression , only : get_compression, compression_bound, compress + use compression , only : compression_suffix use hash , only : get_hash use iso_c_binding, only : c_ptr, c_loc implicit none -! input and output arguments -! character(len=*) , intent(in) :: path, name integer(kind=1), dimension(:), target, intent(in) :: array integer , intent(in) :: hash_type @@ -2822,27 +2808,22 @@ module io integer(kind=8), optional , intent(out) :: array_digest integer(kind=8), optional , intent(out) :: compressed_digest -! local variables -! character(len=512) :: fname integer :: lun = 123 logical :: written - integer :: l, status + integer :: status -! compression buffer -! integer(kind=1), dimension(:), allocatable, target :: buffer - type(c_ptr) :: buffer_ptr -! + type(c_ptr) :: buffer_ptr + !------------------------------------------------------------------------------- ! status = 0 written = .false. array_bytes = size(array, kind=8) if (present(array_digest)) array_digest = get_hash(array, hash_type) - write(fname,"(a,'/',a)") trim(path), trim(name) -! try to compress array and write it +! try to compress the array and store it if compression was successful ! if (present(compressed_bytes) .and. get_compression() > 0) then compressed_bytes = compression_bound(array_bytes) @@ -2851,8 +2832,9 @@ module io if (status == 0) then call compress(c_loc(array), array_bytes, buffer_ptr, compressed_bytes) if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream', status = 'replace') + write(fname,"(a,'/',a,a)") trim(path), trim(name), trim(compression_suffix) + open(newunit=lun, file=fname, form='unformatted', & + access='stream', status='replace') write(lun) buffer(1:compressed_bytes) close(lun) written = .true. @@ -2866,12 +2848,12 @@ module io end if end if -! compression failed of no compression is used, so writhe the uncompressed array +! compression failed or no compression was used, so write the original array ! if (.not. written) then - l = index(fname, '.bin') + 3 - open(newunit = lun, file = fname(:l), form = 'unformatted', & - access = 'stream', status = 'replace') + write(fname,"(a,'/',a)") trim(path), trim(name) + open(newunit=lun, file=fname, form='unformatted', & + access='stream', status='replace') write(lun) array close(lun) end if From a53601ff92f18966413b4aa5b123883c607d8493 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 12:04:30 -0300 Subject: [PATCH 09/25] HASH, IO: Rewrite module HASH. Signed-off-by: Grzegorz Kowal --- sources/hash.F90 | 244 +++++++++++++++++++++++++++++++++++------------ sources/io.F90 | 240 +++++++++++++++++++++++----------------------- 2 files changed, 303 insertions(+), 181 deletions(-) diff --git a/sources/hash.F90 b/sources/hash.F90 index 385e812..112d2b3 100644 --- a/sources/hash.F90 +++ b/sources/hash.F90 @@ -24,9 +24,10 @@ !! !! module: HASH !! -!! This module provides 64-bit version of the xxHash64 by Yann Collet. -!! This is a Fortran implementation based on the XXH64 specification -!! published at +!! This module is an interface to the XXH functions by Yann Collet provided +!! by the library libxxhash. If this library is not available, an internal +!! Fortran implementation of the 64-bit version of the xxHash64 is used. +!! The Fortran implementation is based on the XXH64 specification published at !! https://github.com/Cyan4973/xxHash/blob/dev/doc/xxhash_spec.md !! !! For additional info, see @@ -39,58 +40,56 @@ module hash implicit none #ifdef XXHASH -! interfaces to functions XXH64() and XXH3_64bits() provided -! by the systems library libxxhash +! interfaces to functions XXH64() and XXH3_64bits() provided by +! the library libxxhash ! interface - - integer(c_int64_t) function xxh64_system(input, length, seed) & - bind(C, name="XXH64") + integer(c_int64_t) function xxh64_lib(input, length, seed) & + bind(C, name="XXH64") use iso_c_binding, only: c_ptr, c_size_t, c_int64_t implicit none type(c_ptr) , value :: input integer(kind=c_size_t), value :: length integer(c_int64_t) , value :: seed - end function xxh64_system + end function xxh64_lib - integer(c_int64_t) function xxh3_system(input, length) & - bind(C, name="XXH3_64bits") + integer(c_int64_t) function xxh3_lib(input, length) & + bind(C, name="XXH3_64bits") use iso_c_binding, only: c_ptr, c_size_t, c_int64_t implicit none type(c_ptr) , value :: input integer(kind=c_size_t), value :: length - end function xxh3_system - + end function xxh3_lib end interface #else /* XXHASH */ ! hash parameters ! - integer(kind=8), parameter :: prime1 = -7046029288634856825_8, & - prime2 = -4417276706812531889_8, & - prime3 = 1609587929392839161_8, & - prime4 = -8796714831421723037_8, & - prime5 = 2870177450012600261_8, & + integer(kind=8), parameter :: prime1 = -7046029288634856825_8, & + prime2 = -4417276706812531889_8, & + prime3 = 1609587929392839161_8, & + prime4 = -8796714831421723037_8, & + prime5 = 2870177450012600261_8, & prime6 = 6983438078262162902_8 #endif /* XXHASH */ ! supported hash types ! - integer, parameter :: hash_xxh64 = 1 + enum, bind(c) + enumerator hash_none + enumerator hash_xxh64 #ifdef XXHASH - integer, parameter :: hash_xxh3 = 2 + enumerator hash_xxh3 #endif /* XXHASH */ + end enum private - public :: get_hash, check_hash, hash_string, hash_xxh64 -#ifdef XXHASH - public :: hash_xxh3 -#endif /* XXHASH */ + public :: hash_info, hash_name, digest, check_digest + public :: digest_string, digest_integer !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! contains ! -! !=============================================================================== !! !!*** PUBLIC SUBROUTINES ***************************************************** @@ -99,40 +98,93 @@ module hash ! !=============================================================================== ! -! function HASH_STRING: +! subroutine HASH_INFO: ! -------------------- ! -! Function returns the hash type string. +! Subroutine returns the hash ID and the length in bytes (characters) +! by the provided hash name. ! !=============================================================================== ! - character(len=8) function hash_string(hash_type) + subroutine hash_info(hash_name, hash_id, hash_length) + + use helpers, only : print_message + + implicit none + + character(len=*), intent(in) :: hash_name + integer , intent(out) :: hash_id, hash_length + + character(len=*), parameter :: loc = "HASH::hash_info()" + +!------------------------------------------------------------------------------- +! + select case(trim(hash_name)) + case("xxh64", "XXH64") + hash_id = hash_xxh64 + hash_length = 16 +#ifdef XXHASH + case("xxh3", "XXH3") + hash_id = hash_xxh3 + hash_length = 16 +#endif /* XXHASH */ + case("none") + hash_id = hash_none + hash_length = 0 + case default + call print_message(loc, & + "Hash '" // trim(hash_name) // "' is not supported!") + end select + + return + +!------------------------------------------------------------------------------- +! + end subroutine hash_info +! +!=============================================================================== +! +! function HASH_NAME: +! ------------------ +! +! Function returns the hash name by the provided hash ID. +! +!=============================================================================== +! + character(len=8) function hash_name(hash_type) implicit none integer, intent(in) :: hash_type + integer(kind(hash_none)) :: htype + !------------------------------------------------------------------------------- ! + htype = hash_type + select case(htype) + case(hash_xxh64) + hash_name = "xxh64" #ifdef XXHASH - if (hash_type == hash_xxh3) then - hash_string = 'xxh3' - return - end if + case(hash_xxh3) + hash_name = "xxh3" #endif /* XXHASH */ - hash_string = 'xxh64' + case default + hash_name = "none" + end select + return !------------------------------------------------------------------------------- ! - end function hash_string + end function hash_name ! !=============================================================================== ! -! function GET_HASH: -! ----------------- +! function DIGEST: +! --------------- ! -! Function calculates the hash for a given sequence of bytes. +! Function calculates the digest for a given sequence of bytes. ! ! Arguments: ! @@ -141,7 +193,7 @@ module hash ! !=============================================================================== ! - integer(kind=8) function get_hash(input, hash_type) result(hash) + integer(kind=8) function digest(input, hash_type) result(hash) #ifdef XXHASH use iso_c_binding, only: c_loc @@ -158,45 +210,46 @@ module hash !------------------------------------------------------------------------------- ! -#ifdef XXHASH - hash = 0 - length = size(input, kind=8) - select case(hash_type) - case(hash_xxh3) - hash = xxh3_system(c_loc(input), length) - case default - hash = xxh64_system(c_loc(input), length, hash) - end select + case(hash_xxh64) +#ifndef XXHASH + hash = xxh64(input) #else /* XXHASH */ - hash = xxh64(input) + length = size(input, kind=8) + hash = xxh64_lib(c_loc(input), length, 0_8) + case(hash_xxh3) + length = size(input, kind=8) + hash = xxh3_lib(c_loc(input), length) #endif /* XXHASH */ + case(hash_none) + hash = 0 + end select return !------------------------------------------------------------------------------- ! - end function get_hash + end function digest ! !=============================================================================== ! -! subroutine CHECK_HASH: -! --------------------- +! subroutine CHECK_DIGEST: +! ----------------------- ! ! Subroutine checks if the provided digest matches the digest of ! the input data. ! ! Arguments: ! -! loc - the location of check; -! fname - the file name; -! input - the input sequence of bytes; -! digest - the data digest to check; -! hash_type - the number corresponding to the hash type; +! loc - the location of check; +! fname - the file name; +! input - the input sequence of bytes; +! idigest - the data digest to check; +! hash_id - the hash ID; ! !=============================================================================== ! - subroutine check_hash(loc, fname, input, digest, hash_type) + subroutine check_digest(loc, fname, input, idigest, hash_id) use helpers, only : print_message @@ -204,17 +257,86 @@ module hash character(len=*) , intent(in) :: loc, fname integer(kind=1), dimension(:), intent(in) :: input - integer(kind=8) , intent(in) :: digest - integer , intent(in) :: hash_type + integer(kind=8) , intent(in) :: idigest + integer , intent(in) :: hash_id !------------------------------------------------------------------------------- ! - if (digest /= get_hash(input, hash_type)) & + if (hash_id == hash_none) return + + if (idigest /= digest(input, hash_id)) & call print_message(loc, trim(fname) // " seems to be corrupted!") !------------------------------------------------------------------------------- ! - end subroutine check_hash + end subroutine check_digest +! +!=============================================================================== +! +! subroutine DIGEST_STRING: +! ------------------------ +! +! Subroutine converts the integer digest to string. +! +! Arguments: +! +! idigest - the digest as integer; +! sdigest - the digest as string; +! +!=============================================================================== +! + subroutine digest_string(idigest, sdigest) + + use helpers, only : print_message + + implicit none + + integer(kind=8) , intent(in) :: idigest + character(len=*), intent(inout) :: sdigest + + character(len=*), parameter :: loc = "HASH::digest_string()" + +!------------------------------------------------------------------------------- +! + if (len(sdigest) >= 16) then + write(sdigest,"(1z16.16)") idigest + else + call print_message(loc, & + "The string is too short to contain the whole digest!") + end if + +!------------------------------------------------------------------------------- +! + end subroutine digest_string +! +!=============================================================================== +! +! subroutine DIGEST_INTEGER: +! ------------------------- +! +! Subroutine converts the string digest to its integer representation. +! +! Arguments: +! +! sdigest - the digest as string; +! idigest - the digest as integer; +! +!=============================================================================== +! + subroutine digest_integer(sdigest, idigest) + + implicit none + + character(len=*), intent(in) :: sdigest + integer(kind=8) , intent(out) :: idigest + +!------------------------------------------------------------------------------- +! + read(sdigest, fmt="(1z16)") idigest + +!------------------------------------------------------------------------------- +! + end subroutine digest_integer ! !=============================================================================== !! diff --git a/sources/io.F90 b/sources/io.F90 index bf9a458..b673e4a 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -116,10 +116,10 @@ module io character(len=255), save :: cformat = "none" ! compression format integer , save :: clevel = 3 ! compression level -! the type of digest to use +! the type of digest to use and its length ! - integer , save :: hash_type = 1 - character(len=8) , save :: hash_str = 'xxh64' + integer, save :: hash_type = 0 + integer, save :: hash_length = 0 #ifdef HDF5 ! compression type @@ -175,10 +175,7 @@ module io subroutine initialize_io(verbose, status) use compression, only : set_compression, get_compression - use hash , only : hash_xxh64 -#ifdef XXHASH - use hash , only : hash_xxh3 -#endif /* XXHASH */ + use hash , only : hash_info use helpers , only : print_message use mpitools , only : nproc use parameters , only : get_parameter @@ -277,16 +274,7 @@ module io call set_compression(cformat, clevel) call get_parameter("digest_type", dtype) - select case(dtype) -#ifdef XXHASH - case('xxh3', 'XXH3') - hash_type = hash_xxh3 - hash_str = 'xxh3' -#endif /* XXHASH */ - case default - hash_type = hash_xxh64 - hash_str = 'xxh64' - end select + call hash_info(dtype, hash_type, hash_length) if (status == 0) then @@ -410,6 +398,7 @@ module io ! subroutine print_io(verbose) + use hash , only : hash_name use helpers, only : print_section, print_parameter implicit none @@ -438,7 +427,7 @@ module io #endif /* HDF5 */ case default call print_parameter(verbose, "restart snapshot format", "XML+binary") - call print_parameter(verbose, "digest type", hash_str) + call print_parameter(verbose, "digest type", hash_name(hash_type)) call print_parameter(verbose, "compression format", cformat) call print_parameter(verbose, "compression level", clevel) end select @@ -1007,7 +996,7 @@ module io use evolution , only : step, time, dt, dth, dte use evolution , only : niterations, nrejections, errs use forcing , only : nmodes, fcoefs, einj - use hash , only : check_hash, hash_xxh64 + use hash , only : hash_info, check_digest, digest_integer use helpers , only : print_message #ifdef MPI use mesh , only : redistribute_blocks @@ -1029,6 +1018,8 @@ module io type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata + integer :: dtype, dlen + integer(kind=4) :: lun = 104 integer(kind=8) :: digest, bytes, pbytes, ubytes @@ -1156,6 +1147,10 @@ module io case('errs(3)') read(svalue, fmt = *) errs(3) case('fields') + il = index(line, 'digest_type="') + 13 + iu = index(line(il:), '"') + il - 2 + call hash_info(line(il:iu), dtype, dlen) + il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 read(line(il:iu), fmt = *) hfield @@ -1229,18 +1224,18 @@ module io access = 'stream') read(lun) fields close(lun) - read(hfield, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(fields, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hfield, digest) + call check_digest(loc, fname, transfer(fields, 1_1, bytes), & + digest, dtype) write(fname,"(a,'metablock_children.bin')") trim(dname) bytes = size(transfer(children, [ 0_1 ]), kind=8) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) children close(lun) - read(hchild, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(children, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hchild, digest) + call check_digest(loc, fname, transfer(children, 1_1, bytes), & + digest, dtype) #if NDIMS == 3 bytes = size(transfer(faces, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_faces.bin')") trim(dname) @@ -1248,9 +1243,9 @@ module io access = 'stream') read(lun) faces close(lun) - read(hface, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(faces, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hface, digest) + call check_digest(loc, fname, transfer(faces, 1_1, bytes), & + digest, dtype) #endif /* NDIMS == 3 */ bytes = size(transfer(edges, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_edges.bin')") trim(dname) @@ -1258,27 +1253,27 @@ module io access = 'stream') read(lun) edges close(lun) - read(hedge, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(edges, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hedge, digest) + call check_digest(loc, fname, transfer(edges, 1_1, bytes), & + digest, dtype) bytes = size(transfer(corners, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_corners.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) corners close(lun) - read(hcorner, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(corners, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hcorner, digest) + call check_digest(loc, fname, transfer(corners, 1_1, bytes), & + digest, dtype) bytes = size(transfer(bounds, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_bounds.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) bounds close(lun) - read(hbound, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(bounds, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hbound, digest) + call check_digest(loc, fname, transfer(bounds, 1_1, bytes), & + digest, dtype) l = 0 pmeta => list_meta @@ -1366,9 +1361,9 @@ module io access = 'stream') read(lun) fcoefs close(lun) - read(hforce, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(fcoefs, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hforce, digest) + call check_digest(loc, fname, transfer(fcoefs, 1_1, bytes), & + digest, dtype) end if else call print_message(loc, "The number of forcing modes does not match!") @@ -1425,13 +1420,13 @@ module io read(sname(7:), fmt = *) l il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = "(1z16)") hprim(l) + call digest_integer(line(il:iu), hprim(l)) end if if (index(sname, 'cons') > 0) then read(sname(7:), fmt = *) l il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = "(1z16)") hcons(l) + call digest_integer(line(il:iu), hcons(l)) end if end if end if @@ -1463,9 +1458,9 @@ module io access = 'stream') read(lun) ids close(lun) - read(hids, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(ids, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hids, digest) + call check_digest(loc, fname, transfer(ids, 1_1, bytes), & + digest, dtype) pbytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) ubytes = size(transfer(array(:,:,:,:,:), [ 0_1 ]), kind=8) @@ -1480,8 +1475,8 @@ module io access = 'stream') read(lun) array(:,:,:,:,1) close(lun) - call check_hash(loc, fname, & - transfer(array(:,:,:,:,1), 1_1, pbytes), hprim(l), hash_xxh64) + call check_digest(loc, fname, & + transfer(array(:,:,:,:,1), 1_1, pbytes), hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1503,8 +1498,8 @@ module io access = 'stream') read(lun) array close(lun) - call check_hash(loc, fname, transfer(array, 1_1, ubytes), & - hcons(l), hash_xxh64) + call check_digest(loc, fname, transfer(array, 1_1, ubytes), & + hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1540,9 +1535,9 @@ module io access = 'stream') read(lun) seeds close(lun) - read(hseed, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(seeds, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hseed, digest) + call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & + digest, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1596,9 +1591,9 @@ module io access = 'stream') read(lun) seeds close(lun) - read(hseed, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(seeds, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hseed, digest) + call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & + digest, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1717,9 +1712,9 @@ module io access = 'stream') read(lun) ids close(lun) - read(hids, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(ids, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hids, digest) + call check_digest(loc, fname, transfer(ids, 1_1, bytes), & + digest, dtype) bytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) @@ -1733,8 +1728,8 @@ module io access = 'stream') read(lun) array(:,:,:,:,1) close(lun) - call check_hash(loc, fname, & - transfer(array(:,:,:,:,1), 1_1, bytes), hprim(l), hash_xxh64) + call check_digest(loc, fname, & + transfer(array(:,:,:,:,1), 1_1, bytes), hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1756,8 +1751,8 @@ module io access = 'stream') read(lun) array close(lun) - call check_hash(loc, fname, transfer(array, 1_1, bytes), & - hcons(l), hash_xxh64) + call check_digest(loc, fname, transfer(array, 1_1, bytes), & + hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1793,9 +1788,9 @@ module io access = 'stream') read(lun) seeds close(lun) - read(hseed, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(seeds, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hseed, digest) + call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & + digest, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1816,9 +1811,9 @@ module io access = 'stream') read(lun) seeds close(lun) - read(hseed, fmt = "(1z16)") digest - call check_hash(loc, fname, transfer(seeds, 1_1, bytes), & - digest, hash_xxh64) + call digest_integer(hseed, digest) + call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & + digest, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1870,7 +1865,7 @@ module io use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs use evolution , only : atol, rtol, mrej, niterations, nrejections use forcing , only : nmodes, fcoefs, einj - use hash , only : hash_xxh64, hash_string + use hash , only : hash_info use helpers , only : print_message use mpitools , only : nprocs, nproc use parameters , only : get_parameter_file @@ -1883,9 +1878,10 @@ module io integer , intent(out) :: status logical :: test - character(len=64) :: dname, fname, aname, hname + character(len=64) :: dname, fname, aname integer(kind=8) :: digest, bytes integer(kind=4) :: lun = 103 + integer :: dtype, dlen integer :: nd, nl, nm, nx, i, j, l, n, p #if NDIMS == 3 integer :: k @@ -1916,7 +1912,7 @@ module io ! status = 0 - hname = hash_string(hash_xxh64) + call hash_info("xxh64", dtype, dlen) write(dname, "('restart-',i5.5)") nrun @@ -2113,44 +2109,44 @@ module io write(fname,"(a,'.bin')") "metablock_fields" call write_binary_xml(dname, fname, transfer(fields, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "fields", fname, hname, bytes, digest) + dtype, bytes, digest) + call write_attribute_xml(lun, "fields", fname, dtype, bytes, digest) write(fname,"(a,'.bin')") "metablock_children" call write_binary_xml(dname, fname, transfer(children, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "children", fname, hname, bytes, digest) + dtype, bytes, digest) + call write_attribute_xml(lun, "children", fname, dtype, bytes, digest) #if NDIMS == 3 write(fname,"(a,'.bin')") "metablock_faces" call write_binary_xml(dname, fname, transfer(faces, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "faces", fname, hname, bytes, digest) + dtype, bytes, digest) + call write_attribute_xml(lun, "faces", fname, dtype, bytes, digest) #endif /* NDIMS == 3 */ write(fname,"(a,'.bin')") "metablock_edges" call write_binary_xml(dname, fname, transfer(edges, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "edges", fname, hname, bytes, digest) + dtype, bytes, digest) + call write_attribute_xml(lun, "edges", fname, dtype, bytes, digest) write(fname,"(a,'.bin')") "metablock_corners" call write_binary_xml(dname, fname, transfer(corners, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "corners", trim(fname), trim(hname), & + dtype, bytes, digest) + call write_attribute_xml(lun, "corners", trim(fname), dtype, & bytes, digest) write(fname,"(a,'.bin')") "metablock_bounds" call write_binary_xml(trim(dname), trim(fname), & - transfer(bounds, [ 0_1 ]), hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "bounds", trim(fname), trim(hname), & + transfer(bounds, [ 0_1 ]), dtype, bytes, digest) + call write_attribute_xml(lun, "bounds", trim(fname), dtype, & bytes, digest) if (nmodes > 0) then write(fname,"(a,'.bin')") "forcing_coefficients" call write_binary_xml(trim(dname), trim(fname), & transfer(fcoefs, [ 0_1 ]), & - hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "forcing", trim(fname), trim(hname), & + dtype, bytes, digest) + call write_attribute_xml(lun, "forcing", trim(fname), dtype, & bytes, digest) end if @@ -2214,16 +2210,16 @@ module io write(fname,"('datablock_prim_',i6.6,a,'.bin')") nproc, trim(aname) call write_binary_xml(trim(dname), trim(fname), & transfer(pdata%q, [ 0_1 ]), & - hash_xxh64, bytes, digest) + dtype, bytes, digest) call write_attribute_xml(lun, "prim" // trim(aname), trim(fname), & - trim(hname), bytes, digest) + dtype, bytes, digest) write(fname,"('datablock_cons_',i6.6,a,'.bin')") nproc, trim(aname) call write_binary_xml(trim(dname), trim(fname), & transfer(pdata%uu, [ 0_1 ]), & - hash_xxh64, bytes, digest) + dtype, bytes, digest) call write_attribute_xml(lun, "cons" // trim(aname), trim(fname), & - trim(hname), bytes, digest) + dtype, bytes, digest) pdata => pdata%next @@ -2231,8 +2227,8 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc call write_binary_xml(trim(dname), trim(fname), & - transfer(ids, [ 0_1 ]), hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "ids", trim(fname), trim(hname), & + transfer(ids, [ 0_1 ]), dtype, bytes, digest) + call write_attribute_xml(lun, "ids", trim(fname), dtype, & bytes, digest) if (allocated(ids)) deallocate(ids) @@ -2253,8 +2249,8 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc call write_binary_xml(trim(dname), trim(fname), & - transfer(seeds, [ 0_1 ]), hash_xxh64, bytes, digest) - call write_attribute_xml(lun, "seeds", trim(fname), trim(hname), & + transfer(seeds, [ 0_1 ]), dtype, bytes, digest) + call write_attribute_xml(lun, "seeds", trim(fname), dtype, & bytes, digest) if (allocated(seeds)) deallocate(seeds) @@ -2463,13 +2459,13 @@ module io write(fname,"(a,'.bin')") "metablock_fields" call write_binary_xml(dname, fname, transfer(fields, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "fields", fname, hash_str, & + call write_attribute_xml(lun, "fields", fname, hash_type, & dbytes, ddigest, cbytes, cdigest) write(fname,"(a,'.bin')") "metablock_bounds" call write_binary_xml(dname, fname, transfer(bounds, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "bounds", fname, hash_str, & + call write_attribute_xml(lun, "bounds", fname, hash_type, & dbytes, ddigest, cbytes, cdigest) if (allocated(fields)) deallocate(fields) @@ -2528,7 +2524,7 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc call write_binary_xml(dname, fname, transfer(ids, [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "ids", fname, hash_str, & + call write_attribute_xml(lun, "ids", fname, hash_type, & dbytes, ddigest, cbytes, cdigest) do p = 1, nv @@ -2547,7 +2543,7 @@ module io call write_binary_xml(dname, fname, & transfer(array(:,:,:,:), [ 0_1 ]), & hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, pvars(p), fname, hash_str, & + call write_attribute_xml(lun, pvars(p), fname, hash_type, & dbytes, ddigest, cbytes, cdigest) end do @@ -2720,44 +2716,48 @@ module io ! !=============================================================================== ! - subroutine write_attribute_xml_file(lun, aname, filename, & - hash_string, data_bytes, data_digest, & + subroutine write_attribute_xml_file(lun, aname, filename, & + digest_type, data_bytes, data_digest, & compressed_bytes, compressed_digest) use compression, only : compression_suffix + use hash , only : hash_name, digest_string implicit none integer , intent(in) :: lun - character(len=*) , intent(in) :: aname, filename, hash_string + character(len=*) , intent(in) :: aname, filename + integer , intent(in) :: digest_type integer(kind=8) , intent(in) :: data_bytes, data_digest - integer(kind=8) , optional, intent(in) :: compressed_bytes, compressed_digest + integer(kind=8) , optional, intent(in) :: compressed_bytes + integer(kind=8) , optional, intent(in) :: compressed_digest character(len=256) :: fname - character(len=32) :: digest_string, bytes_string character(len=1024) :: string + character(len=32) :: str !------------------------------------------------------------------------------- ! fname = filename string = ' 0) then fname = trim(fname) // trim(compression_suffix) - write(bytes_string,"(1i32)") compressed_bytes - string = trim(string) // & - ' compression_format="' // trim(adjustl(cformat)) // '"' // & - ' compressed_size="' // trim(adjustl(bytes_string)) // '"' + write(str,"(1i0)") compressed_bytes + string = trim(string) // & + ' compression_format="' // trim(adjustl(cformat)) // & + '" compressed_size="' // trim(adjustl(str)) // '"' if (present(compressed_digest)) then if (compressed_digest /= 0) then - write(digest_string,"(1z0.16)") compressed_digest - string = trim(string) // ' compressed_digest="' // & - trim(adjustl(digest_string)) // '"' + call digest_string(compressed_digest, str) + string = trim(string) // & + ' compressed_digest="' // trim(adjustl(str)) // '"' end if end if end if @@ -2781,7 +2781,7 @@ module io ! ! path, name - the path and name where the array should be written to; ! array - the array of bytes to be written; -! hash_type - the type of digest to hash the data; +! dtype - the type of digest to hash the data; ! array_bytes - the size of the array in bytes; ! array_digest - the digest of the input array; ! compressed_bytes - the size of the compressed array in bytes; @@ -2789,20 +2789,20 @@ module io ! !=============================================================================== ! - subroutine write_binary_xml(path, name, array, hash_type, & + subroutine write_binary_xml(path, name, array, digest_type, & array_bytes, array_digest, & compressed_bytes, compressed_digest) use compression , only : get_compression, compression_bound, compress use compression , only : compression_suffix - use hash , only : get_hash + use hash , only : digest use iso_c_binding, only : c_ptr, c_loc implicit none character(len=*) , intent(in) :: path, name integer(kind=1), dimension(:), target, intent(in) :: array - integer , intent(in) :: hash_type + integer , intent(in) :: digest_type integer(kind=8), optional , intent(out) :: array_bytes integer(kind=8), optional , intent(out) :: compressed_bytes integer(kind=8), optional , intent(out) :: array_digest @@ -2821,7 +2821,7 @@ module io status = 0 written = .false. array_bytes = size(array, kind=8) - if (present(array_digest)) array_digest = get_hash(array, hash_type) + if (present(array_digest)) array_digest = digest(array, digest_type) ! try to compress the array and store it if compression was successful ! @@ -2839,7 +2839,7 @@ module io close(lun) written = .true. if (present(compressed_digest)) & - compressed_digest = get_hash(buffer(1:compressed_bytes), hash_type) + compressed_digest = digest(buffer(1:compressed_bytes), digest_type) else compressed_bytes = 0 compressed_digest = 0 From b5183dfa0eb55474445f82fac3b3d58b02bf47d8 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 12:20:14 -0300 Subject: [PATCH 10/25] IO: Store hashes as integers in read_restart_snapshot_xml(). Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 96 ++++++++++++++++++-------------------------------- 1 file changed, 35 insertions(+), 61 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index b673e4a..0611dbc 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1023,8 +1023,8 @@ module io integer(kind=4) :: lun = 104 integer(kind=8) :: digest, bytes, pbytes, ubytes - character(len=16) :: hfield, hchild, hface, hedge, hcorner, hbound - character(len=16) :: hids, harray, hseed, hforce + integer(kind=8) :: hfield, hchild, hface, hedge, hcorner, hbound + integer(kind=8) :: hids, hseed, hforce integer(kind=8), dimension(:) , allocatable :: hprim, hcons integer(kind=4), dimension(:) , allocatable :: ids @@ -1153,31 +1153,31 @@ module io il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hfield + call digest_integer(line(il:iu), hfield) case('children') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hchild + call digest_integer(line(il:iu), hchild) case('faces') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hface + call digest_integer(line(il:iu), hface) case('edges') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hedge + call digest_integer(line(il:iu), hedge) case('corners') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hcorner + call digest_integer(line(il:iu), hcorner) case('bounds') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hbound + call digest_integer(line(il:iu), hbound) case('forcing') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hforce + call digest_integer(line(il:iu), hforce) end select end if end if @@ -1224,18 +1224,15 @@ module io access = 'stream') read(lun) fields close(lun) - call digest_integer(hfield, digest) - call check_digest(loc, fname, transfer(fields, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, transfer(fields, 1_1, bytes), hfield, dtype) write(fname,"(a,'metablock_children.bin')") trim(dname) bytes = size(transfer(children, [ 0_1 ]), kind=8) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) children close(lun) - call digest_integer(hchild, digest) - call check_digest(loc, fname, transfer(children, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(children, 1_1, bytes), hchild, dtype) #if NDIMS == 3 bytes = size(transfer(faces, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_faces.bin')") trim(dname) @@ -1243,9 +1240,7 @@ module io access = 'stream') read(lun) faces close(lun) - call digest_integer(hface, digest) - call check_digest(loc, fname, transfer(faces, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, transfer(faces, 1_1, bytes), hface, dtype) #endif /* NDIMS == 3 */ bytes = size(transfer(edges, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_edges.bin')") trim(dname) @@ -1253,27 +1248,22 @@ module io access = 'stream') read(lun) edges close(lun) - call digest_integer(hedge, digest) - call check_digest(loc, fname, transfer(edges, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, transfer(edges, 1_1, bytes), hedge, dtype) bytes = size(transfer(corners, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_corners.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) corners close(lun) - call digest_integer(hcorner, digest) - call check_digest(loc, fname, transfer(corners, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(corners, 1_1, bytes), hcorner, dtype) bytes = size(transfer(bounds, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_bounds.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) bounds close(lun) - call digest_integer(hbound, digest) - call check_digest(loc, fname, transfer(bounds, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, transfer(bounds, 1_1, bytes), hbound, dtype) l = 0 pmeta => list_meta @@ -1361,9 +1351,8 @@ module io access = 'stream') read(lun) fcoefs close(lun) - call digest_integer(hforce, digest) - call check_digest(loc, fname, transfer(fcoefs, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(fcoefs, 1_1, bytes), hforce, dtype) end if else call print_message(loc, "The number of forcing modes does not match!") @@ -1406,15 +1395,11 @@ module io case('ids') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hids - case('arrays') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) harray + call digest_integer(line(il:iu), hids) case('seeds') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hseed + call digest_integer(line(il:iu), hseed) end select if (index(sname, 'prim') > 0) then read(sname(7:), fmt = *) l @@ -1458,9 +1443,8 @@ module io access = 'stream') read(lun) ids close(lun) - call digest_integer(hids, digest) - call check_digest(loc, fname, transfer(ids, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(ids, 1_1, bytes), hids, dtype) pbytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) ubytes = size(transfer(array(:,:,:,:,:), [ 0_1 ]), kind=8) @@ -1535,9 +1519,8 @@ module io access = 'stream') read(lun) seeds close(lun) - call digest_integer(hseed, digest) - call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(seeds, 1_1, bytes), hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1570,7 +1553,7 @@ module io case('seeds') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hseed + call digest_integer(line(il:iu), hseed) end select end if end if @@ -1591,9 +1574,8 @@ module io access = 'stream') read(lun) seeds close(lun) - call digest_integer(hseed, digest) - call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(seeds, 1_1, bytes), hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1671,15 +1653,11 @@ module io case('ids') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hids - case('arrays') - il = index(line, 'digest="') + 8 - iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) harray + call digest_integer(line(il:iu), hids) case('seeds') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 - read(line(il:iu), fmt = *) hseed + call digest_integer(line(il:iu), hseed) end select end if end if @@ -1712,9 +1690,8 @@ module io access = 'stream') read(lun) ids close(lun) - call digest_integer(hids, digest) - call check_digest(loc, fname, transfer(ids, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(ids, 1_1, bytes), hids, dtype) bytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) @@ -1788,9 +1765,8 @@ module io access = 'stream') read(lun) seeds close(lun) - call digest_integer(hseed, digest) - call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, & + transfer(seeds, 1_1, bytes), hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1811,9 +1787,7 @@ module io access = 'stream') read(lun) seeds close(lun) - call digest_integer(hseed, digest) - call check_digest(loc, fname, transfer(seeds, 1_1, bytes), & - digest, dtype) + call check_digest(loc, fname, transfer(seeds, 1_1, bytes), hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) From 398b3e331d0175a166d6f3e944dee73915b6a465 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 12:59:43 -0300 Subject: [PATCH 11/25] HASH: Rewrite internal xxh64() to accept pointer instead of array. Signed-off-by: Grzegorz Kowal --- sources/hash.F90 | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/sources/hash.F90 b/sources/hash.F90 index 112d2b3..f2be75f 100644 --- a/sources/hash.F90 +++ b/sources/hash.F90 @@ -195,25 +195,22 @@ module hash ! integer(kind=8) function digest(input, hash_type) result(hash) -#ifdef XXHASH use iso_c_binding, only: c_loc -#endif /* XXHASH */ implicit none integer(kind=1), dimension(:), target, intent(in) :: input integer , intent(in) :: hash_type -#ifdef XXHASH integer(kind=8) :: length -#endif /* XXHASH */ !------------------------------------------------------------------------------- ! select case(hash_type) case(hash_xxh64) #ifndef XXHASH - hash = xxh64(input) + length = size(input, kind=8) + hash = xxh64(c_loc(input), length) #else /* XXHASH */ length = size(input, kind=8) hash = xxh64_lib(c_loc(input), length, 0_8) @@ -354,24 +351,30 @@ module hash ! ! Arguments: ! -! input - the input sequence of bytes; +! buffer - the buffer pointer; +! length - the buffer length; ! !=============================================================================== ! - integer(kind=8) function xxh64(input) result(hash) + integer(kind=8) function xxh64(buffer, length) result(hash) + + use iso_c_binding, only: c_ptr, c_f_pointer implicit none - integer(kind=1), dimension(:), target, intent(in) :: input + type(c_ptr) , intent(in) :: buffer + integer(kind=8), intent(in) :: length - integer(kind=8) :: length integer(kind=8) :: remaining, offset integer(kind=8), dimension(4) :: lane, chunk + integer(kind=1), dimension(:), pointer :: input + !------------------------------------------------------------------------------- ! - length = size(input, kind=8) + call c_f_pointer(buffer, input, [ length ]) + hash = 0_8 offset = 1_8 remaining = length From cb2d7b09cf2917c16adb4a232f6e185f838dc4ef Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 14:23:22 -0300 Subject: [PATCH 12/25] HASH, IO: Pass pointers to the hash functions instead of arrays. Signed-off-by: Grzegorz Kowal --- sources/hash.F90 | 50 +++++++------- sources/io.F90 | 165 ++++++++++++++++++++++++----------------------- 2 files changed, 108 insertions(+), 107 deletions(-) diff --git a/sources/hash.F90 b/sources/hash.F90 index f2be75f..7157341 100644 --- a/sources/hash.F90 +++ b/sources/hash.F90 @@ -188,35 +188,32 @@ module hash ! ! Arguments: ! -! input - the input sequence of bytes; -! hash_type - the number corresponding to the hash type; +! buffer - the buffer pointer; +! length - the buffer length; +! hash_id - the hash ID; ! !=============================================================================== ! - integer(kind=8) function digest(input, hash_type) result(hash) + integer(kind=8) function digest(buffer, length, hash_id) result(hash) - use iso_c_binding, only: c_loc + use iso_c_binding, only : c_ptr implicit none - integer(kind=1), dimension(:), target, intent(in) :: input - integer , intent(in) :: hash_type - - integer(kind=8) :: length + type(c_ptr) , intent(in) :: buffer + integer(kind=8), intent(in) :: length + integer , intent(in) :: hash_id !------------------------------------------------------------------------------- ! - select case(hash_type) + select case(hash_id) case(hash_xxh64) #ifndef XXHASH - length = size(input, kind=8) - hash = xxh64(c_loc(input), length) + hash = xxh64(buffer, length) #else /* XXHASH */ - length = size(input, kind=8) - hash = xxh64_lib(c_loc(input), length, 0_8) + hash = xxh64_lib(buffer, length, 0_8) case(hash_xxh3) - length = size(input, kind=8) - hash = xxh3_lib(c_loc(input), length) + hash = xxh3_lib(buffer, length) #endif /* XXHASH */ case(hash_none) hash = 0 @@ -240,28 +237,31 @@ module hash ! ! loc - the location of check; ! fname - the file name; -! input - the input sequence of bytes; -! idigest - the data digest to check; +! buffer - the buffer pointer; +! length - the buffer length; +! bdigest - the buffer digest to check; ! hash_id - the hash ID; ! !=============================================================================== ! - subroutine check_digest(loc, fname, input, idigest, hash_id) + subroutine check_digest(loc, fname, buffer, length, bdigest, hash_id) - use helpers, only : print_message + use helpers , only : print_message + use iso_c_binding, only : c_ptr implicit none - character(len=*) , intent(in) :: loc, fname - integer(kind=1), dimension(:), intent(in) :: input - integer(kind=8) , intent(in) :: idigest - integer , intent(in) :: hash_id + character(len=*), intent(in) :: loc, fname + type(c_ptr) , intent(in) :: buffer + integer(kind=8) , intent(in) :: length + integer(kind=8) , intent(in) :: bdigest + integer , intent(in) :: hash_id !------------------------------------------------------------------------------- ! if (hash_id == hash_none) return - if (idigest /= digest(input, hash_id)) & + if (bdigest /= digest(buffer, length, hash_id)) & call print_message(loc, trim(fname) // " seems to be corrupted!") !------------------------------------------------------------------------------- @@ -358,7 +358,7 @@ module hash ! integer(kind=8) function xxh64(buffer, length) result(hash) - use iso_c_binding, only: c_ptr, c_f_pointer + use iso_c_binding, only : c_ptr, c_f_pointer implicit none diff --git a/sources/io.F90 b/sources/io.F90 index 0611dbc..ddf2146 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -978,31 +978,32 @@ module io ! subroutine read_restart_snapshot_xml(status) - use blocks , only : block_meta, block_data, pointer_meta, list_meta - use blocks , only : ns => nsides, nc => nchildren, nregs - use blocks , only : append_metablock, append_datablock, link_blocks - use blocks , only : get_mblocks - use blocks , only : set_last_id, get_last_id - use blocks , only : metablock_set_id, metablock_set_process - use blocks , only : metablock_set_refinement - use blocks , only : metablock_set_configuration - use blocks , only : metablock_set_level, metablock_set_position - use blocks , only : metablock_set_coordinates, metablock_set_bounds - use blocks , only : metablock_set_leaf - use blocks , only : change_blocks_process - use coordinates, only : nn => bcells, ncells, nghosts - use coordinates, only : xmin, xmax, ymin, ymax, zmin, zmax - use equations , only : cmax, cmax2 - use evolution , only : step, time, dt, dth, dte - use evolution , only : niterations, nrejections, errs - use forcing , only : nmodes, fcoefs, einj - use hash , only : hash_info, check_digest, digest_integer - use helpers , only : print_message + use blocks , only : block_meta, block_data, pointer_meta, list_meta + use blocks , only : ns => nsides, nc => nchildren, nregs + use blocks , only : append_metablock, append_datablock, link_blocks + use blocks , only : get_mblocks + use blocks , only : set_last_id, get_last_id + use blocks , only : metablock_set_id, metablock_set_process + use blocks , only : metablock_set_refinement + use blocks , only : metablock_set_configuration + use blocks , only : metablock_set_level, metablock_set_position + use blocks , only : metablock_set_coordinates, metablock_set_bounds + use blocks , only : metablock_set_leaf + use blocks , only : change_blocks_process + use coordinates , only : nn => bcells, ncells, nghosts + use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax + use equations , only : cmax, cmax2 + use evolution , only : step, time, dt, dth, dte + use evolution , only : niterations, nrejections, errs + use forcing , only : nmodes, fcoefs, einj + use hash , only : hash_info, check_digest, digest_integer + use helpers , only : print_message + use iso_c_binding, only : c_loc #ifdef MPI - use mesh , only : redistribute_blocks + use mesh , only : redistribute_blocks #endif /* MPI */ - use mpitools , only : nprocs, nproc - use random , only : gentype, set_seeds + use mpitools , only : nprocs, nproc + use random , only : gentype, set_seeds implicit none @@ -1026,22 +1027,23 @@ module io integer(kind=8) :: hfield, hchild, hface, hedge, hcorner, hbound integer(kind=8) :: hids, hseed, hforce - integer(kind=8), dimension(:) , allocatable :: hprim, hcons - integer(kind=4), dimension(:) , allocatable :: ids - integer(kind=4), dimension(:,:) , allocatable :: fields - integer(kind=4), dimension(:,:) , allocatable :: children + integer(kind=8), dimension(:) , allocatable :: hprim, hcons + integer(kind=4), dimension(:) , allocatable, target :: ids + integer(kind=4), dimension(:,:) , allocatable, target :: fields + integer(kind=4), dimension(:,:) , allocatable, target :: children #if NDIMS == 2 - integer(kind=4), dimension(:,:,:,:) , allocatable :: edges - integer(kind=4), dimension(:,:,:) , allocatable :: corners + integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges + integer(kind=4), dimension(:,:,:) , allocatable, target :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 - integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces - integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges - integer(kind=4), dimension(:,:,:,:) , allocatable :: corners + integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces + integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges + integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners #endif /* NDIMS == 3 */ - integer(kind=8), dimension(:,:) , allocatable :: seeds - real(kind=8) , dimension(:,:,:) , allocatable :: bounds - real(kind=8) , dimension(:,:,:,:,:), allocatable :: array + integer(kind=8), dimension(:,:) , allocatable, target :: seeds + real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds + real(kind=8) , dimension(:,:,:,:,:), allocatable, target :: array + complex(kind=8), dimension(:,:) , allocatable, target :: lfcoefs character(len=*), parameter :: loc = 'IO::read_restart_snapshot_xml()' character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" @@ -1218,52 +1220,50 @@ module io if (status == 0) then - bytes = size(transfer(fields, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_fields.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) fields close(lun) - call check_digest(loc, fname, transfer(fields, 1_1, bytes), hfield, dtype) + bytes = size(fields, kind=8) * kind(fields) + call check_digest(loc, fname, c_loc(fields), bytes, hfield, dtype) write(fname,"(a,'metablock_children.bin')") trim(dname) - bytes = size(transfer(children, [ 0_1 ]), kind=8) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) children close(lun) - call check_digest(loc, fname, & - transfer(children, 1_1, bytes), hchild, dtype) + bytes = size(children, kind=8) * kind(children) + call check_digest(loc, fname, c_loc(children), bytes, hchild, dtype) #if NDIMS == 3 - bytes = size(transfer(faces, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_faces.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) faces close(lun) - call check_digest(loc, fname, transfer(faces, 1_1, bytes), hface, dtype) + bytes = size(faces, kind=8) * kind(faces) + call check_digest(loc, fname, c_loc(faces), bytes, hface, dtype) #endif /* NDIMS == 3 */ - bytes = size(transfer(edges, [ 0_1 ]), kind=8) write(fname,"(a,'metablock_edges.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) edges close(lun) - call check_digest(loc, fname, transfer(edges, 1_1, bytes), hedge, dtype) - bytes = size(transfer(corners, [ 0_1 ]), kind=8) + bytes = size(edges, kind=8) * kind(edges) + call check_digest(loc, fname, c_loc(edges), bytes, hedge, dtype) write(fname,"(a,'metablock_corners.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) corners close(lun) - call check_digest(loc, fname, & - transfer(corners, 1_1, bytes), hcorner, dtype) - bytes = size(transfer(bounds, [ 0_1 ]), kind=8) + bytes = size(corners, kind=8) * kind(corners) + call check_digest(loc, fname, c_loc(corners), bytes, hcorner, dtype) write(fname,"(a,'metablock_bounds.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) bounds close(lun) - call check_digest(loc, fname, transfer(bounds, 1_1, bytes), hbound, dtype) + bytes = size(bounds, kind=8) * kind(bounds) + call check_digest(loc, fname, c_loc(bounds), bytes, hbound, dtype) l = 0 pmeta => list_meta @@ -1345,14 +1345,16 @@ module io if (lnmodes == nmodes) then if (lnmodes > 0) then - bytes = size(transfer(fcoefs, [ 0_1 ]), kind=8) + allocate(lfcoefs(lnmodes,lndims)) write(fname,"(a,'forcing_coefficients.bin')") trim(dname) open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') - read(lun) fcoefs + read(lun) lfcoefs close(lun) - call check_digest(loc, fname, & - transfer(fcoefs, 1_1, bytes), hforce, dtype) + bytes = size(lfcoefs, kind=8) * kind(lfcoefs) + call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype) + fcoefs = lfcoefs + deallocate(lfcoefs) end if else call print_message(loc, "The number of forcing modes does not match!") @@ -1437,17 +1439,16 @@ module io if (status == 0) then - bytes = size(transfer(ids, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "datablock_ids", nproc, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) ids close(lun) - call check_digest(loc, fname, & - transfer(ids, 1_1, bytes), hids, dtype) + bytes = size(ids, kind=8) * kind(ids) + call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype) - pbytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) - ubytes = size(transfer(array(:,:,:,:,:), [ 0_1 ]), kind=8) + ubytes = size(array, kind=8) * kind(array) + pbytes = ubytes / nr do l = 1, nd call append_datablock(pdata, status) @@ -1460,7 +1461,7 @@ module io read(lun) array(:,:,:,:,1) close(lun) call check_digest(loc, fname, & - transfer(array(:,:,:,:,1), 1_1, pbytes), hprim(l), dtype) + c_loc(array), pbytes, hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1482,8 +1483,8 @@ module io access = 'stream') read(lun) array close(lun) - call check_digest(loc, fname, transfer(array, 1_1, ubytes), & - hcons(l), dtype) + call check_digest(loc, fname, & + c_loc(array), ubytes, hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1513,14 +1514,13 @@ module io if (status == 0) then - bytes = size(transfer(seeds, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) seeds close(lun) - call check_digest(loc, fname, & - transfer(seeds, 1_1, bytes), hseed, dtype) + bytes = size(seeds, kind=8) * kind(seeds) + call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1568,14 +1568,13 @@ module io if (status == 0) then - bytes = size(transfer(seeds, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "random_seeds", 0, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) seeds close(lun) - call check_digest(loc, fname, & - transfer(seeds, 1_1, bytes), hseed, dtype) + bytes = size(seeds, kind=8) * kind(seeds) + call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1684,16 +1683,16 @@ module io if (status == 0) then - bytes = size(transfer(ids, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "datablock_ids", nproc, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) ids close(lun) - call check_digest(loc, fname, & - transfer(ids, 1_1, bytes), hids, dtype) + bytes = size(ids, kind=8) * kind(ids) + call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype) - bytes = size(transfer(array(:,:,:,:,1), [ 0_1 ]), kind=8) + ubytes = size(array, kind=8) * kind(array) + pbytes = ubytes / nr do l = 1, nd call append_datablock(pdata, status) @@ -1706,7 +1705,7 @@ module io read(lun) array(:,:,:,:,1) close(lun) call check_digest(loc, fname, & - transfer(array(:,:,:,:,1), 1_1, bytes), hprim(l), dtype) + c_loc(array), pbytes, hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1728,8 +1727,8 @@ module io access = 'stream') read(lun) array close(lun) - call check_digest(loc, fname, transfer(array, 1_1, bytes), & - hcons(l), dtype) + call check_digest(loc, fname, & + c_loc(array), ubytes, hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1759,14 +1758,13 @@ module io if (status == 0) then - bytes = size(transfer(seeds, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) seeds close(lun) - call check_digest(loc, fname, & - transfer(seeds, 1_1, bytes), hseed, dtype) + bytes = size(seeds, kind=8) * kind(seeds) + call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -1781,13 +1779,13 @@ module io if (status == 0) then - bytes = size(transfer(seeds, [ 0_1 ]), kind=8) write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" open(newunit = lun, file = fname, form = 'unformatted', & access = 'stream') read(lun) seeds close(lun) - call check_digest(loc, fname, transfer(seeds, 1_1, bytes), hseed, dtype) + bytes = size(seeds, kind=8) * kind(seeds) + call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) if (allocated(seeds)) deallocate(seeds) @@ -2795,7 +2793,8 @@ module io status = 0 written = .false. array_bytes = size(array, kind=8) - if (present(array_digest)) array_digest = digest(array, digest_type) + if (present(array_digest)) & + array_digest = digest(c_loc(array), array_bytes, digest_type) ! try to compress the array and store it if compression was successful ! @@ -2806,14 +2805,16 @@ module io if (status == 0) then call compress(c_loc(array), array_bytes, buffer_ptr, compressed_bytes) if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then - write(fname,"(a,'/',a,a)") trim(path), trim(name), trim(compression_suffix) + write(fname,"(a,'/',a,a)") trim(path), trim(name), & + trim(compression_suffix) open(newunit=lun, file=fname, form='unformatted', & access='stream', status='replace') write(lun) buffer(1:compressed_bytes) close(lun) written = .true. if (present(compressed_digest)) & - compressed_digest = digest(buffer(1:compressed_bytes), digest_type) + compressed_digest = digest(buffer_ptr, & + compressed_bytes, digest_type) else compressed_bytes = 0 compressed_digest = 0 From 863b7c5a853f75eb0f1ce82f0fea560747e2c3f5 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 17:45:33 -0300 Subject: [PATCH 13/25] IO: Rewrite write_binary_xml() so it accepts a pointer instead of array. Signed-off-by: Grzegorz Kowal --- sources/forcing.F90 | 2 +- sources/io.F90 | 245 ++++++++++++++++++++++---------------------- 2 files changed, 124 insertions(+), 123 deletions(-) diff --git a/sources/forcing.F90 b/sources/forcing.F90 index 080e001..1978ff8 100644 --- a/sources/forcing.F90 +++ b/sources/forcing.F90 @@ -113,7 +113,7 @@ module forcing ! array for driving mode coefficients ! - complex(kind=8), dimension(:,:), allocatable :: fcoefs + complex(kind=8), dimension(:,:), allocatable, target :: fcoefs ! velocity Fourier coefficients in Alfvelius method ! diff --git a/sources/io.F90 b/sources/io.F90 index ddf2146..92be526 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1022,7 +1022,7 @@ module io integer :: dtype, dlen integer(kind=4) :: lun = 104 - integer(kind=8) :: digest, bytes, pbytes, ubytes + integer(kind=8) :: bytes, pbytes, ubytes integer(kind=8) :: hfield, hchild, hface, hedge, hcorner, hbound integer(kind=8) :: hids, hseed, hforce @@ -1823,25 +1823,26 @@ module io ! subroutine store_restart_snapshot_xml(problem, nrun, status) - use blocks , only : block_meta, block_data, list_meta, list_data - use blocks , only : get_mblocks, get_dblocks, get_nleafs - use blocks , only : get_last_id - use blocks , only : ns => nsides, nc => nchildren, nr => nregs - use coordinates, only : nn => bcells, ncells, nghosts, minlev, maxlev - use coordinates, only : xmin, xmax, ymin, ymax + use blocks , only : block_meta, block_data, list_meta, list_data + use blocks , only : get_mblocks, get_dblocks, get_nleafs + use blocks , only : get_last_id + use blocks , only : ns => nsides, nc => nchildren, nr => nregs + use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev + use coordinates , only : xmin, xmax, ymin, ymax #if NDIMS == 3 - use coordinates, only : zmin, zmax + use coordinates , only : zmin, zmax #endif /* NDIMS == 3 */ - use coordinates, only : bdims => domain_base_dims - use equations , only : eqsys, eos, nv, cmax - use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs - use evolution , only : atol, rtol, mrej, niterations, nrejections - use forcing , only : nmodes, fcoefs, einj - use hash , only : hash_info - use helpers , only : print_message - use mpitools , only : nprocs, nproc - use parameters , only : get_parameter_file - use random , only : gentype, nseeds, get_seeds + use coordinates , only : bdims => domain_base_dims + use equations , only : eqsys, eos, nv, cmax + use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs + use evolution , only : atol, rtol, mrej, niterations, nrejections + use forcing , only : nmodes, fcoefs, einj + use hash , only : hash_info + use helpers , only : print_message + use iso_c_binding, only : c_loc + use mpitools , only : nprocs, nproc + use parameters , only : get_parameter_file + use random , only : gentype, nseeds, get_seeds implicit none @@ -1862,20 +1863,20 @@ module io type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata - integer(kind=4), dimension(:) , allocatable :: ids - integer(kind=4), dimension(:,:) , allocatable :: fields - integer(kind=4), dimension(:,:) , allocatable :: children + integer(kind=4), dimension(:) , allocatable, target :: ids + integer(kind=4), dimension(:,:) , allocatable, target :: fields + integer(kind=4), dimension(:,:) , allocatable, target :: children #if NDIMS == 2 - integer(kind=4), dimension(:,:,:,:) , allocatable :: edges - integer(kind=4), dimension(:,:,:) , allocatable :: corners + integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges + integer(kind=4), dimension(:,:,:) , allocatable, target :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 - integer(kind=4), dimension(:,:,:,:,:) , allocatable :: faces - integer(kind=4), dimension(:,:,:,:,:) , allocatable :: edges - integer(kind=4), dimension(:,:,:,:) , allocatable :: corners + integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces + integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges + integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners #endif /* NDIMS == 3 */ - integer(kind=8), dimension(:,:) , allocatable :: seeds - real(kind=8) , dimension(:,:,:) , allocatable :: bounds + integer(kind=8), dimension(:,:) , allocatable, target :: seeds + real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()" character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" @@ -2080,46 +2081,42 @@ module io end do write(fname,"(a,'.bin')") "metablock_fields" - call write_binary_xml(dname, fname, transfer(fields, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "fields", fname, dtype, bytes, digest) + bytes = size(fields, kind=8) * kind(fields) + call write_binary_xml(dname, fname, c_loc(fields), bytes, dtype, digest) + call write_attribute_xml(lun, "fields", fname, bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_children" - call write_binary_xml(dname, fname, transfer(children, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "children", fname, dtype, bytes, digest) + bytes = size(children, kind=8) * kind(children) + call write_binary_xml(dname, fname, c_loc(children), bytes, dtype, digest) + call write_attribute_xml(lun, "children", fname, bytes, dtype, digest) #if NDIMS == 3 write(fname,"(a,'.bin')") "metablock_faces" - call write_binary_xml(dname, fname, transfer(faces, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "faces", fname, dtype, bytes, digest) + bytes = size(faces, kind=8) * kind(faces) + call write_binary_xml(dname, fname, c_loc(faces), bytes, dtype, digest) + call write_attribute_xml(lun, "faces", fname, bytes, dtype, digest) #endif /* NDIMS == 3 */ write(fname,"(a,'.bin')") "metablock_edges" - call write_binary_xml(dname, fname, transfer(edges, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "edges", fname, dtype, bytes, digest) + bytes = size(edges, kind=8) * kind(edges) + call write_binary_xml(dname, fname, c_loc(edges), bytes, dtype, digest) + call write_attribute_xml(lun, "edges", fname, bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_corners" - call write_binary_xml(dname, fname, transfer(corners, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "corners", trim(fname), dtype, & - bytes, digest) + bytes = size(corners, kind=8) * kind(corners) + call write_binary_xml(dname, fname, c_loc(corners), bytes, dtype, digest) + call write_attribute_xml(lun, "corners", fname, bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_bounds" - call write_binary_xml(trim(dname), trim(fname), & - transfer(bounds, [ 0_1 ]), dtype, bytes, digest) - call write_attribute_xml(lun, "bounds", trim(fname), dtype, & - bytes, digest) + bytes = size(bounds, kind=8) * kind(bounds) + call write_binary_xml(dname, fname, c_loc(bounds), bytes, dtype, digest) + call write_attribute_xml(lun, "bounds", fname, bytes, dtype, digest) if (nmodes > 0) then write(fname,"(a,'.bin')") "forcing_coefficients" - call write_binary_xml(trim(dname), trim(fname), & - transfer(fcoefs, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "forcing", trim(fname), dtype, & - bytes, digest) + bytes = size(fcoefs, kind=8) * kind(fcoefs) + call write_binary_xml(dname, fname, c_loc(fcoefs), bytes, dtype, digest) + call write_attribute_xml(lun, "forcing", fname, bytes, dtype, digest) end if #if NDIMS == 3 @@ -2180,28 +2177,27 @@ module io write(aname,"('_',i6.6)") l write(fname,"('datablock_prim_',i6.6,a,'.bin')") nproc, trim(aname) - call write_binary_xml(trim(dname), trim(fname), & - transfer(pdata%q, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "prim" // trim(aname), trim(fname), & - dtype, bytes, digest) + bytes = size(pdata%q, kind=8) * kind(pdata%q) + call write_binary_xml(dname, fname, c_loc(pdata%q), & + bytes, dtype, digest) + call write_attribute_xml(lun, "prim" // trim(aname), fname, & + bytes, dtype, digest) write(fname,"('datablock_cons_',i6.6,a,'.bin')") nproc, trim(aname) - call write_binary_xml(trim(dname), trim(fname), & - transfer(pdata%uu, [ 0_1 ]), & - dtype, bytes, digest) - call write_attribute_xml(lun, "cons" // trim(aname), trim(fname), & - dtype, bytes, digest) + bytes = size(pdata%uu, kind=8) * kind(pdata%uu) + call write_binary_xml(dname, fname, c_loc(pdata%uu), & + bytes, dtype, digest) + call write_attribute_xml(lun, "cons" // trim(aname), fname, & + bytes, dtype, digest) pdata => pdata%next end do write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc - call write_binary_xml(trim(dname), trim(fname), & - transfer(ids, [ 0_1 ]), dtype, bytes, digest) - call write_attribute_xml(lun, "ids", trim(fname), dtype, & - bytes, digest) + bytes = size(ids, kind=8) * kind(ids) + call write_binary_xml(dname, fname, c_loc(ids), bytes, dtype, digest) + call write_attribute_xml(lun, "ids", fname, bytes, dtype, digest) if (allocated(ids)) deallocate(ids) @@ -2220,10 +2216,9 @@ module io call get_seeds(seeds(:,:)) write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc - call write_binary_xml(trim(dname), trim(fname), & - transfer(seeds, [ 0_1 ]), dtype, bytes, digest) - call write_attribute_xml(lun, "seeds", trim(fname), dtype, & - bytes, digest) + bytes = size(seeds, kind=8) * kind(seeds) + call write_binary_xml(dname, fname, c_loc(seeds), bytes, dtype, digest) + call write_attribute_xml(lun, "seeds", fname, bytes, dtype, digest) if (allocated(seeds)) deallocate(seeds) @@ -2260,20 +2255,21 @@ module io ! subroutine store_snapshot_xml(problem, status) - use blocks , only : block_meta, block_data, list_meta, list_data - use blocks , only : get_dblocks, get_nleafs - use coordinates, only : nn => bcells, ncells, nghosts, minlev, maxlev - use coordinates, only : xmin, xmax, ymin, ymax + use blocks , only : block_meta, block_data, list_meta, list_data + use blocks , only : get_dblocks, get_nleafs + use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev + use coordinates , only : xmin, xmax, ymin, ymax #if NDIMS == 3 - use coordinates, only : zmin, zmax + use coordinates , only : zmin, zmax #endif /* NDIMS == 3 */ - use coordinates, only : bdims => domain_base_dims - use equations , only : eqsys, eos, nv, pvars, adiabatic_index, csnd - use evolution , only : step, time, dt, cfl, glm_alpha - use helpers , only : print_message - use mpitools , only : nprocs, nproc - use parameters , only : get_parameter_file - use sources , only : viscosity, resistivity + use coordinates , only : bdims => domain_base_dims + use equations , only : eqsys, eos, nv, pvars, adiabatic_index, csnd + use evolution , only : step, time, dt, cfl, glm_alpha + use helpers , only : print_message + use iso_c_binding, only : c_loc + use mpitools , only : nprocs, nproc + use parameters , only : get_parameter_file + use sources , only : viscosity, resistivity implicit none @@ -2291,16 +2287,14 @@ module io type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata - integer(kind=4), dimension(:) , allocatable :: ids - integer(kind=4), dimension(:,:) , allocatable :: fields - real(kind=8) , dimension(:,:,:) , allocatable :: bounds - real(kind=8) , dimension(:,:,:,:), allocatable :: array + integer(kind=4), dimension(:) , allocatable, target :: ids + integer(kind=4), dimension(:,:) , allocatable, target :: fields + real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds + real(kind=8) , dimension(:,:,:,:), allocatable, target :: array -! local parameters -! character(len=*), parameter :: loc = "IO::store_snapshot_xml()" character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" -! + !------------------------------------------------------------------------------- ! status = 0 @@ -2429,16 +2423,18 @@ module io end do write(fname,"(a,'.bin')") "metablock_fields" - call write_binary_xml(dname, fname, transfer(fields, [ 0_1 ]), & - hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "fields", fname, hash_type, & - dbytes, ddigest, cbytes, cdigest) + dbytes = size(fields, kind=8) * kind(fields) + call write_binary_xml(dname, fname, c_loc(fields), & + dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, "fields", fname, & + dbytes, hash_type, ddigest, cbytes, cdigest) write(fname,"(a,'.bin')") "metablock_bounds" - call write_binary_xml(dname, fname, transfer(bounds, [ 0_1 ]), & - hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "bounds", fname, hash_type, & - dbytes, ddigest, cbytes, cdigest) + dbytes = size(bounds, kind=8) * kind(bounds) + call write_binary_xml(dname, fname, c_loc(bounds), & + dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, "bounds", fname, & + dbytes, hash_type, ddigest, cbytes, cdigest) if (allocated(fields)) deallocate(fields) if (allocated(bounds)) deallocate(bounds) @@ -2494,10 +2490,13 @@ module io end do ! data blocks write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc - call write_binary_xml(dname, fname, transfer(ids, [ 0_1 ]), & - hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "ids", fname, hash_type, & - dbytes, ddigest, cbytes, cdigest) + dbytes = size(ids, kind=8) * kind(ids) + call write_binary_xml(dname, fname, c_loc(ids), & + dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, "ids", fname, & + dbytes, hash_type, ddigest, cbytes, cdigest) + + dbytes = size(array, kind=8) * kind(array) do p = 1, nv @@ -2512,11 +2511,10 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", & trim(pvars(p)), nproc - call write_binary_xml(dname, fname, & - transfer(array(:,:,:,:), [ 0_1 ]), & - hash_type, dbytes, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, pvars(p), fname, hash_type, & - dbytes, ddigest, cbytes, cdigest) + call write_binary_xml(dname, fname, c_loc(array), & + dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, pvars(p), fname, & + dbytes, hash_type, ddigest, cbytes, cdigest) end do if (allocated(ids)) deallocate(ids) @@ -2688,8 +2686,8 @@ module io ! !=============================================================================== ! - subroutine write_attribute_xml_file(lun, aname, filename, & - digest_type, data_bytes, data_digest, & + subroutine write_attribute_xml_file(lun, aname, filename, data_bytes, & + digest_type, data_digest, & compressed_bytes, compressed_digest) use compression, only : compression_suffix @@ -2752,30 +2750,30 @@ module io ! Arguments: ! ! path, name - the path and name where the array should be written to; -! array - the array of bytes to be written; -! dtype - the type of digest to hash the data; +! array_ptr - the pointer to the array to store; ! array_bytes - the size of the array in bytes; -! array_digest - the digest of the input array; +! digest_type - the type of digest to hash the data; +! array_digest - the digest of the original array; ! compressed_bytes - the size of the compressed array in bytes; ! compressed_digest - the digest of the compressed array; ! !=============================================================================== ! - subroutine write_binary_xml(path, name, array, digest_type, & - array_bytes, array_digest, & - compressed_bytes, compressed_digest) + subroutine write_binary_xml(path, name, array_ptr, array_bytes, digest_type, & + array_digest, compressed_bytes, compressed_digest) use compression , only : get_compression, compression_bound, compress use compression , only : compression_suffix use hash , only : digest - use iso_c_binding, only : c_ptr, c_loc + use iso_c_binding, only : c_ptr, c_loc, c_f_pointer implicit none - character(len=*) , intent(in) :: path, name - integer(kind=1), dimension(:), target, intent(in) :: array + character(len=*), intent(in) :: path, name + type(c_ptr) , intent(in) :: array_ptr + integer(kind=8) , intent(in) :: array_bytes + integer , intent(in) :: digest_type - integer(kind=8), optional , intent(out) :: array_bytes integer(kind=8), optional , intent(out) :: compressed_bytes integer(kind=8), optional , intent(out) :: array_digest integer(kind=8), optional , intent(out) :: compressed_digest @@ -2785,6 +2783,8 @@ module io logical :: written integer :: status + integer(kind=1), dimension(:), pointer :: array + integer(kind=1), dimension(:), allocatable, target :: buffer type(c_ptr) :: buffer_ptr @@ -2792,9 +2792,8 @@ module io ! status = 0 written = .false. - array_bytes = size(array, kind=8) if (present(array_digest)) & - array_digest = digest(c_loc(array), array_bytes, digest_type) + array_digest = digest(array_ptr, array_bytes, digest_type) ! try to compress the array and store it if compression was successful ! @@ -2803,7 +2802,7 @@ module io allocate(buffer(compressed_bytes), stat = status) buffer_ptr = c_loc(buffer) if (status == 0) then - call compress(c_loc(array), array_bytes, buffer_ptr, compressed_bytes) + call compress(array_ptr, array_bytes, buffer_ptr, compressed_bytes) if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then write(fname,"(a,'/',a,a)") trim(path), trim(name), & trim(compression_suffix) @@ -2826,6 +2825,8 @@ module io ! compression failed or no compression was used, so write the original array ! if (.not. written) then + call c_f_pointer(array_ptr, array, [ array_bytes ]) + write(fname,"(a,'/',a)") trim(path), trim(name) open(newunit=lun, file=fname, form='unformatted', & access='stream', status='replace') From 0ac1fec2d705049d151565deeee818931fc3efad Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 18:22:21 -0300 Subject: [PATCH 14/25] IO: Rewrite read_restart_snapshot_xml() a bit. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 304 +++++++++++++++++++++++++------------------------ 1 file changed, 156 insertions(+), 148 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 92be526..20da80b 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1046,7 +1046,7 @@ module io complex(kind=8), dimension(:,:) , allocatable, target :: lfcoefs character(len=*), parameter :: loc = 'IO::read_restart_snapshot_xml()' - character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" + character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" !------------------------------------------------------------------------------- ! @@ -1055,9 +1055,9 @@ module io write(dname, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) + inquire(directory=dname, exist=test) #else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) + inquire(file=dname, exist=test) #endif /* __INTEL_COMPILER */ if (.not. test) then call print_message(loc, trim(dname) // " does not exist!") @@ -1067,15 +1067,15 @@ module io dname = trim(dname) // "/" write(fname,"(a,'metadata.xml')") trim(dname) - inquire(file = fname, exist = test) + inquire(file=fname, exist=test) if (.not. test) then call print_message(loc, trim(fname) // " does not exist!") status = 121 return end if - open(newunit = lun, file = fname, status = 'old') -10 read(lun, fmt = "(a)", end = 20) line + open(newunit=lun, file=fname, status='old') +10 read(lun, fmt="(a)", end=20) line if (index(line, ' 0) then il = index(line, 'name="') if (il > 0) then @@ -1083,71 +1083,71 @@ module io iu = index(line(il:), '"') + il - 2 write(sname,*) line(il:iu) il = index(line, '>') + 1 - iu = index(line, '<', back = .true.) - 1 + iu = index(line, '<', back=.true.) - 1 write(svalue,*) line(il:iu) select case(trim(adjustl(sname))) case('ndims') - read(svalue, fmt = *) lndims + read(svalue, fmt=*) lndims case('nprocs') - read(svalue, fmt = *) lnprocs + read(svalue, fmt=*) lnprocs case('nproc') - read(svalue, fmt = *) lnproc + read(svalue, fmt=*) lnproc case('mblocks') - read(svalue, fmt = *) lmblocks + read(svalue, fmt=*) lmblocks case('dblocks') - read(svalue, fmt = *) ldblocks + read(svalue, fmt=*) ldblocks case('nleafs') - read(svalue, fmt = *) lnleafs + read(svalue, fmt=*) lnleafs case('last_id') - read(svalue, fmt = *) llast_id + read(svalue, fmt=*) llast_id case('ncells') - read(svalue, fmt = *) lncells + read(svalue, fmt=*) lncells case('nghosts') - read(svalue, fmt = *) lnghosts + read(svalue, fmt=*) lnghosts case('nseeds') - read(svalue, fmt = *) lnseeds + read(svalue, fmt=*) lnseeds case('step') - read(svalue, fmt = *) step + read(svalue, fmt=*) step case('isnap') - read(svalue, fmt = *) isnap + read(svalue, fmt=*) isnap case('nvars') - read(svalue, fmt = *) nv + read(svalue, fmt=*) nv case('nmodes') - read(svalue, fmt = *) lnmodes + read(svalue, fmt=*) lnmodes case('xmin') - read(svalue, fmt = *) xmin + read(svalue, fmt=*) xmin case('xmax') - read(svalue, fmt = *) xmax + read(svalue, fmt=*) xmax case('ymin') - read(svalue, fmt = *) ymin + read(svalue, fmt=*) ymin case('ymax') - read(svalue, fmt = *) ymax + read(svalue, fmt=*) ymax case('zmin') - read(svalue, fmt = *) zmin + read(svalue, fmt=*) zmin case('zmax') - read(svalue, fmt = *) zmax + read(svalue, fmt=*) zmax case('time') - read(svalue, fmt = *) time + read(svalue, fmt=*) time case('dt') - read(svalue, fmt = *) dt + read(svalue, fmt=*) dt case('dth') - read(svalue, fmt = *) dth + read(svalue, fmt=*) dth case('dte') - read(svalue, fmt = *) dte + read(svalue, fmt=*) dte case('cmax') - read(svalue, fmt = *) cmax + read(svalue, fmt=*) cmax cmax2 = cmax * cmax case('niterations') - read(svalue, fmt = *) niterations + read(svalue, fmt=*) niterations case('nrejections') - read(svalue, fmt = *) nrejections + read(svalue, fmt=*) nrejections case('errs(1)') - read(svalue, fmt = *) errs(1) + read(svalue, fmt=*) errs(1) case('errs(2)') - read(svalue, fmt = *) errs(2) + read(svalue, fmt=*) errs(2) case('errs(3)') - read(svalue, fmt = *) errs(3) + read(svalue, fmt=*) errs(3) case('fields') il = index(line, 'digest_type="') + 13 iu = index(line(il:), '"') + il - 2 @@ -1216,50 +1216,44 @@ module io #else /* NDIMS == 3 */ edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), & #endif /* NDIMS == 3 */ - block_array(nx), stat = status) + block_array(nx), stat=status) if (status == 0) then write(fname,"(a,'metablock_fields.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) fields close(lun) bytes = size(fields, kind=8) * kind(fields) call check_digest(loc, fname, c_loc(fields), bytes, hfield, dtype) write(fname,"(a,'metablock_children.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) children close(lun) bytes = size(children, kind=8) * kind(children) call check_digest(loc, fname, c_loc(children), bytes, hchild, dtype) #if NDIMS == 3 write(fname,"(a,'metablock_faces.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) faces close(lun) bytes = size(faces, kind=8) * kind(faces) call check_digest(loc, fname, c_loc(faces), bytes, hface, dtype) #endif /* NDIMS == 3 */ write(fname,"(a,'metablock_edges.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) edges close(lun) bytes = size(edges, kind=8) * kind(edges) call check_digest(loc, fname, c_loc(edges), bytes, hedge, dtype) write(fname,"(a,'metablock_corners.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) corners close(lun) bytes = size(corners, kind=8) * kind(corners) call check_digest(loc, fname, c_loc(corners), bytes, hcorner, dtype) write(fname,"(a,'metablock_bounds.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) bounds close(lun) bytes = size(bounds, kind=8) * kind(bounds) @@ -1339,22 +1333,31 @@ module io deallocate(fields, children, bounds, edges, corners, stat=status) #endif /* NDIMS == 3 */ if (status /= 0) & - call print_message(loc, "Could not deallocate space of metablocks!") + call print_message(loc, "Could not release space of metablocks!") + else + call print_message(loc, "Could not allocate space of metablocks!") end if if (lnmodes == nmodes) then if (lnmodes > 0) then - allocate(lfcoefs(lnmodes,lndims)) - write(fname,"(a,'forcing_coefficients.bin')") trim(dname) - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') - read(lun) lfcoefs - close(lun) - bytes = size(lfcoefs, kind=8) * kind(lfcoefs) - call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype) - fcoefs = lfcoefs - deallocate(lfcoefs) + allocate(lfcoefs(lnmodes,lndims), stat=status) + if (status == 0) then + write(fname,"(a,'forcing_coefficients.bin')") trim(dname) + open(newunit=lun, file=fname, form='unformatted', access='stream') + read(lun) lfcoefs + close(lun) + bytes = size(lfcoefs, kind=8) * kind(lfcoefs) + call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype) + fcoefs = lfcoefs + deallocate(lfcoefs, stat=status) + if (status /= 0) & + call print_message(loc, & + "Could not release space of Fourier coefficients!") + else + call print_message(loc, & + "Could not allocate space of Fourier coefficients!") + end if end if else call print_message(loc, "The number of forcing modes does not match!") @@ -1364,16 +1367,16 @@ module io if (nproc < lnprocs) then - write(fname,fmt) trim(dname), "datablocks", nproc, "xml" - inquire(file = fname, exist = test) + write(fname,sfmt) trim(dname), "datablocks", nproc, "xml" + inquire(file=fname, exist=test) if (.not. test) then write(*,*) trim(fname) // " does not exist!" status = 121 return end if - open(newunit = lun, file = fname, status = 'old') -30 read(lun, fmt = "(a)", end = 40) line + open(newunit=lun, file=fname, status='old') +30 read(lun, fmt="(a)", end=40) line if (index(line, ' 0) then il = index(line, 'name="') if (il > 0) then @@ -1381,19 +1384,22 @@ module io iu = index(line(il:), '"') + il - 2 write(sname,*) line(il:iu) il = index(line, '>') + 1 - iu = index(line, '<', back = .true.) - 1 + iu = index(line, '<', back=.true.) - 1 write(svalue,*) line(il:iu) select case(trim(adjustl(sname))) case('dblocks') - read(svalue, fmt = *) nd + read(svalue, fmt=*) nd if (nd > 0) then - allocate(hprim(nd), hcons(nd), stat = status) + allocate(hprim(nd), hcons(nd), stat=status) + if (status /= 0) & + call print_message(loc, & + "Could not allocate space for hashes!") end if case('nregs') - read(svalue, fmt = *) nr + read(svalue, fmt=*) nr case('einj') - read(svalue, fmt = *) einj + read(svalue, fmt=*) einj case('ids') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 @@ -1404,13 +1410,13 @@ module io call digest_integer(line(il:iu), hseed) end select if (index(sname, 'prim') > 0) then - read(sname(7:), fmt = *) l + read(sname(7:), fmt=*) l il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 call digest_integer(line(il:iu), hprim(l)) end if if (index(sname, 'cons') > 0) then - read(sname(7:), fmt = *) l + read(sname(7:), fmt=*) l il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 call digest_integer(line(il:iu), hcons(l)) @@ -1432,16 +1438,15 @@ module io if (nd > 0) then #if NDIMS == 3 - allocate(ids(nd), array(nv,nm,nm,nm,nr), stat = status) + allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status) #else /* NDIMS == 3 */ - allocate(ids(nd), array(nv,nm,nm, 1,nr), stat = status) + allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status) #endif /* NDIMS == 3 */ if (status == 0) then - write(fname, fmt) trim(dname), "datablock_ids", nproc, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "datablock_ids", nproc, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) ids close(lun) bytes = size(ids, kind=8) * kind(ids) @@ -1455,13 +1460,12 @@ module io call link_blocks(block_array(ids(l))%ptr, pdata) write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + trim(dname), nproc, l + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array(:,:,:,:,1) close(lun) - call check_digest(loc, fname, & - c_loc(array), pbytes, hprim(l), dtype) + call check_digest(loc, fname, c_loc(array), & + pbytes, hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1478,13 +1482,12 @@ module io end if write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + trim(dname), nproc, l + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array close(lun) - call check_digest(loc, fname, & - c_loc(array), ubytes, hcons(l), dtype) + call check_digest(loc, fname, c_loc(array), & + ubytes, hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1504,41 +1507,43 @@ module io deallocate(ids, array, hprim, hcons, stat=status) if (status /= 0) & - call print_message(loc, "Could not release memory!") + call print_message(loc, "Could not release space of datablocks!") else - call print_message(loc, "Could not allocate memory!") + call print_message(loc, "Could not allocate space for datablocks!") end if end if - allocate(seeds(4,lnseeds), stat = status) + allocate(seeds(4,lnseeds), stat=status) if (status == 0) then - write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) seeds close(lun) bytes = size(seeds, kind=8) * kind(seeds) call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) - if (allocated(seeds)) deallocate(seeds) - + deallocate(seeds, stat=status) + if (status /= 0) & + call print_message(loc, "Could not release space of seeds!") + else + call print_message(loc, "Could not allocate space for seeds!") end if else ! nproc < lnprocs - write(fname,fmt) trim(dname), "datablocks", 0, "xml" - inquire(file = fname, exist = test) + write(fname,sfmt) trim(dname), "datablocks", 0, "xml" + inquire(file=fname, exist=test) if (.not. test) then write(*,*) trim(fname) // " does not exist!" status = 121 return end if - open(newunit = lun, file = fname, status = 'old') -50 read(lun, fmt = "(a)", end = 60) line + open(newunit=lun, file=fname, status='old') +50 read(lun, fmt="(a)", end=60) line if (index(line, ' 0) then il = index(line, 'name="') if (il > 0) then @@ -1546,7 +1551,7 @@ module io iu = index(line(il:), '"') + il - 2 write(sname,*) line(il:iu) il = index(line, '>') + 1 - iu = index(line, '<', back = .true.) - 1 + iu = index(line, '<', back=.true.) - 1 write(svalue,*) line(il:iu) select case(trim(adjustl(sname))) @@ -1564,22 +1569,24 @@ module io ! if (trim(gentype) == "same") then - allocate(seeds(4,lnseeds), stat = status) + allocate(seeds(4,lnseeds), stat=status) if (status == 0) then - write(fname, fmt) trim(dname), "random_seeds", 0, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "random_seeds", 0, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) seeds close(lun) bytes = size(seeds, kind=8) * kind(seeds) call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) - if (allocated(seeds)) deallocate(seeds) - - end if ! allocation + deallocate(seeds, stat=status) + if (status /= 0) & + call print_message(loc, "Could not release space of seeds!") + else + call print_message(loc, "Could not allocate space for seeds!") + end if end if ! gentype == "same" @@ -1620,8 +1627,8 @@ module io do n = nl, nu - write(fname,fmt) trim(dname), "datablocks", n, "xml" - inquire(file = fname, exist = test) + write(fname,sfmt) trim(dname), "datablocks", n, "xml" + inquire(file=fname, exist=test) if (.not. test) then write(*,*) trim(fname) // " does not exist!" status = 121 @@ -1630,8 +1637,8 @@ module io ! read attributes from the metadata file ! - open(newunit = lun, file = fname, status = 'old') -70 read(lun, fmt = "(a)", end = 80) line + open(newunit=lun, file=fname, status='old') +70 read(lun, fmt="(a)", end=80) line if (index(line, ' 0) then il = index(line, 'name="') if (il > 0) then @@ -1639,16 +1646,16 @@ module io iu = index(line(il:), '"') + il - 2 write(sname,*) line(il:iu) il = index(line, '>') + 1 - iu = index(line, '<', back = .true.) - 1 + iu = index(line, '<', back=.true.) - 1 write(svalue,*) line(il:iu) select case(trim(adjustl(sname))) case('dblocks') - read(svalue, fmt = *) nd + read(svalue, fmt=*) nd case('nregs') - read(svalue, fmt = *) nr + read(svalue, fmt=*) nr case('einj') - read(svalue, fmt = *) deinj + read(svalue, fmt=*) deinj case('ids') il = index(line, 'digest="') + 8 iu = index(line(il:), '"') + il - 2 @@ -1676,16 +1683,15 @@ module io if (nd > 0) then #if NDIMS == 3 - allocate(ids(nd), array(nv,nm,nm,nm,nr), stat = status) + allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status) #else /* NDIMS == 3 */ - allocate(ids(nd), array(nv,nm,nm, 1,nr), stat = status) + allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status) #endif /* NDIMS == 3 */ if (status == 0) then - write(fname, fmt) trim(dname), "datablock_ids", nproc, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "datablock_ids", nproc, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) ids close(lun) bytes = size(ids, kind=8) * kind(ids) @@ -1699,13 +1705,12 @@ module io call link_blocks(block_array(ids(l))%ptr, pdata) write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + trim(dname), nproc, l + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array(:,:,:,:,1) close(lun) - call check_digest(loc, fname, & - c_loc(array), pbytes, hprim(l), dtype) + call check_digest(loc, fname, c_loc(array), & + pbytes, hprim(l), dtype) if (lnghosts >= nghosts) then #if NDIMS == 3 @@ -1722,13 +1727,12 @@ module io end if write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + trim(dname), nproc, l + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array close(lun) - call check_digest(loc, fname, & - c_loc(array), ubytes, hcons(l), dtype) + call check_digest(loc, fname, c_loc(array), & + ubytes, hcons(l), dtype) p = min(nregs, nr) if (lnghosts >= nghosts) then @@ -1748,48 +1752,52 @@ module io deallocate(ids, array, hprim, hcons, stat=status) if (status /= 0) & - call print_message(loc, "Could not release memory!") + call print_message(loc, "Could not release space of datablocks!") else - call print_message(loc, "Could not allocate memory!") + call print_message(loc, "Could not allocate space for datablocks!") end if end if - allocate(seeds(4,lnseeds), stat = status) + allocate(seeds(4,lnseeds), stat=status) if (status == 0) then - write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) seeds close(lun) bytes = size(seeds, kind=8) * kind(seeds) call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) - if (allocated(seeds)) deallocate(seeds) - + deallocate(seeds, stat=status) + if (status /= 0) & + call print_message(loc, "Could not release space of seeds!") + else + call print_message(loc, "Could not allocate space for seeds!") end if end do ! n = nl, nu ! restore seeds ! - allocate(seeds(4,lnseeds), stat = status) + allocate(seeds(4,lnseeds), stat=status) if (status == 0) then - write(fname, fmt) trim(dname), "random_seeds", nproc, "bin" - open(newunit = lun, file = fname, form = 'unformatted', & - access = 'stream') + write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin" + open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) seeds close(lun) bytes = size(seeds, kind=8) * kind(seeds) call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) call set_seeds(lnseeds, seeds(:,:), .false.) - if (allocated(seeds)) deallocate(seeds) - + deallocate(seeds, stat=status) + if (status /= 0) & + call print_message(loc, "Could not release space of seeds!") + else + call print_message(loc, "Could not allocate space for seeds!") end if ! allocation end if ! nprocs >= lnprocs @@ -1879,7 +1887,7 @@ module io real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()" - character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" + character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" !------------------------------------------------------------------------------- ! @@ -2139,7 +2147,7 @@ module io end if - write(fname,fmt) trim(dname), "datablocks", nproc, "xml" + write(fname,sfmt) trim(dname), "datablocks", nproc, "xml" open(newunit = lun, file = fname, status = 'replace') write(lun,"(a)") "" write(lun,"(a)") '' @@ -2293,7 +2301,7 @@ module io real(kind=8) , dimension(:,:,:,:), allocatable, target :: array character(len=*), parameter :: loc = "IO::store_snapshot_xml()" - character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)" + character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" !------------------------------------------------------------------------------- ! @@ -2453,7 +2461,7 @@ module io ! prepare and store data block info ! - write(fname,fmt) trim(dname), "datablocks", nproc, "xml" + write(fname,sfmt) trim(dname), "datablocks", nproc, "xml" open(newunit = lun, file = fname, status = 'replace') write(lun,"(a)") "" write(lun,"(a)") '' From 657a608ce05347bc04dbadd91b60c9e3ab611f92 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 19:02:32 -0300 Subject: [PATCH 15/25] PYTHON: Add support for XXH3 hash. Signed-off-by: Grzegorz Kowal --- python/amunpy/src/amunpy/amunxml.py | 36 +++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/python/amunpy/src/amunpy/amunxml.py b/python/amunpy/src/amunpy/amunxml.py index 5bdbfda..78d4902 100644 --- a/python/amunpy/src/amunpy/amunxml.py +++ b/python/amunpy/src/amunpy/amunxml.py @@ -208,14 +208,18 @@ class AmunXML(Amun): return self.__swap__(dset) - def __check_digest(self, filename, digest, data): + def __check_digest(self, filename, hash_type, digest, data): ''' - Verifies if the provided digest matches the XXH64 hash of data - stored in the given filename. + Verifies if the provided digest matches the data. ''' import xxhash - if digest.lower() != xxhash.xxh64(data).hexdigest(): + failed = False + if hash_type == 'xxh64': + failed = digest.lower() != xxhash.xxh64(data).hexdigest() + elif hash_type == 'xxh3': + failed = digest.lower() != xxhash.xxh3_64(data).hexdigest() + if failed: print("File '{}' seems to be corrupted! Proceeding anyway...".format(filename)) @@ -235,7 +239,9 @@ class AmunXML(Amun): if 'compression_format' in self.binaries[dataset]: if 'compressed_digest' in self.binaries[dataset]: - self.__check_digest(fname, self.binaries[dataset]['compressed_digest'], stream) + htype = self.binaries[dataset]['digest_type'] + dhash = self.binaries[dataset]['compressed_digest'] + self.__check_digest(fname, htype, dhash, stream) comp = self.binaries[dataset]['compression_format'] if comp == 'zstd': @@ -248,12 +254,16 @@ class AmunXML(Amun): raise Exception("Binary file '{}' compressed in unsupported format {}!".format(fname, comp)) if 'digest' in self.binaries[dataset]: - self.__check_digest(fname, self.binaries[dataset]['digest'], data) + htype = self.binaries[dataset]['digest_type'] + dhash = self.binaries[dataset]['digest'] + self.__check_digest(fname, htype, dhash, data) return numpy.frombuffer(data, dtype=dtype) else: if 'digest' in self.binaries[dataset]: - self.__check_digest(fname, self.binaries[dataset]['digest'], stream) + htype = self.binaries[dataset]['digest_type'] + dhash = self.binaries[dataset]['digest'] + self.__check_digest(fname, htype, dhash, stream) return numpy.frombuffer(stream, dtype=dtype) else: @@ -276,7 +286,9 @@ class AmunXML(Amun): if 'compression_format' in self.chunks[chunk_number][dataset_name]: if 'compressed_digest' in self.chunks[chunk_number][dataset_name]: - self.__check_digest(fname, self.chunks[chunk_number][dataset_name]['compressed_digest'], stream) + htype = self.chunks[chunk_number][dataset_name]['digest_type'] + dhash = self.chunks[chunk_number][dataset_name]['compressed_digest'] + self.__check_digest(fname, htype, dhash, stream) comp = self.chunks[chunk_number][dataset_name]['compression_format'] if comp == 'zstd': @@ -290,12 +302,16 @@ class AmunXML(Amun): raise Exception("Binary file '{}' compressed in unsupported format {}!".format(fname, comp)) if 'digest' in self.chunks[chunk_number][dataset_name]: - self.__check_digest(fname, self.chunks[chunk_number][dataset_name]['digest'], data) + htype = self.chunks[chunk_number][dataset_name]['digest_type'] + dhash = self.chunks[chunk_number][dataset_name]['digest'] + self.__check_digest(fname, htype, dhash, data) return numpy.frombuffer(data, dtype=dtype) else: if 'digest' in self.chunks[chunk_number][dataset_name]: - self.__check_digest(fname, self.chunks[chunk_number][dataset_name]['digest'], stream) + htype = self.chunks[chunk_number][dataset_name]['digest_type'] + dhash = self.chunks[chunk_number][dataset_name]['digest'] + self.__check_digest(fname, htype, dhash, stream) return numpy.frombuffer(stream, dtype=dtype) else: From cc48f698034cd8971075179adeb3f9c3ba3d0d90 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Tue, 30 Nov 2021 22:53:53 -0300 Subject: [PATCH 16/25] IO: Fix the restart from the XML files with less processes. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 47 ++++++++++++++++++++++------------------------- 1 file changed, 22 insertions(+), 25 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 20da80b..32393d7 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1652,6 +1652,12 @@ module io select case(trim(adjustl(sname))) case('dblocks') read(svalue, fmt=*) nd + if (nd > 0) then + allocate(hprim(nd), hcons(nd), stat=status) + if (status /= 0) & + call print_message(loc, & + "Could not allocate space for hashes!") + end if case('nregs') read(svalue, fmt=*) nr case('einj') @@ -1665,6 +1671,18 @@ module io iu = index(line(il:), '"') + il - 2 call digest_integer(line(il:iu), hseed) end select + if (index(sname, 'prim') > 0) then + read(sname(7:), fmt=*) l + il = index(line, 'digest="') + 8 + iu = index(line(il:), '"') + il - 2 + call digest_integer(line(il:iu), hprim(l)) + end if + if (index(sname, 'cons') > 0) then + read(sname(7:), fmt=*) l + il = index(line, 'digest="') + 8 + iu = index(line(il:), '"') + il - 2 + call digest_integer(line(il:iu), hcons(l)) + end if end if end if go to 70 @@ -1690,7 +1708,7 @@ module io if (status == 0) then - write(fname,sfmt) trim(dname), "datablock_ids", nproc, "bin" + write(fname,sfmt) trim(dname), "datablock_ids", n, "bin" open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) ids close(lun) @@ -1705,7 +1723,7 @@ module io call link_blocks(block_array(ids(l))%ptr, pdata) write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l + trim(dname), n, l open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array(:,:,:,:,1) close(lun) @@ -1727,7 +1745,7 @@ module io end if write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") & - trim(dname), nproc, l + trim(dname), n, l open(newunit=lun, file=fname, form='unformatted', access='stream') read(lun) array close(lun) @@ -1758,29 +1776,8 @@ module io end if end if - allocate(seeds(4,lnseeds), stat=status) - - if (status == 0) then - - write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin" - open(newunit=lun, file=fname, form='unformatted', access='stream') - read(lun) seeds - close(lun) - bytes = size(seeds, kind=8) * kind(seeds) - call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype) - call set_seeds(lnseeds, seeds(:,:), .false.) - - deallocate(seeds, stat=status) - if (status /= 0) & - call print_message(loc, "Could not release space of seeds!") - else - call print_message(loc, "Could not allocate space for seeds!") - end if - end do ! n = nl, nu -! restore seeds -! allocate(seeds(4,lnseeds), stat=status) if (status == 0) then @@ -1798,7 +1795,7 @@ module io call print_message(loc, "Could not release space of seeds!") else call print_message(loc, "Could not allocate space for seeds!") - end if ! allocation + end if end if ! nprocs >= lnprocs From e50c65e7dd227f7b66d8e0e82ad88e65f1c45292 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 08:55:39 -0300 Subject: [PATCH 17/25] IO: Rewrite file division in read_restart_snapshot_xml(). Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 41 ++++++++++++++++------------------------- 1 file changed, 16 insertions(+), 25 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 32393d7..c91cbfc 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1594,35 +1594,26 @@ module io else ! nprocs < lnprocs -! divide files between processes +! divide files between processes and update the block process accordingly ! nl = 0 - i = mod(lnprocs, nprocs) - j = lnprocs / nprocs - do p = 0, nprocs - k = 0 - do n = 0, p - nl = k - if (n < i) then - nu = k + j - else - nu = k + j - 1 - end if - k = nu + 1 - end do - do n = nl, nu - call change_blocks_process(n, p) - end do - end do - k = 0 - do n = 0, nproc - nl = k - if (n < i) then - nu = k + j + nd = lnprocs / nprocs + nr = mod(lnprocs, nprocs) + do n = 0, nprocs - 1 + if (n < nr) then + il = n * (nd + 1) + iu = il + nd else - nu = k + j - 1 + il = n * nd + nr + iu = il + nd - 1 + end if + do i = il, iu + call change_blocks_process(i, n) + end do + if (n == nproc) then + nl = il + nu = iu end if - k = nu + 1 end do do n = nl, nu From b85dfafef1ed391a7fb0fe762aa7b80f00270e02 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 09:19:06 -0300 Subject: [PATCH 18/25] IO: Rewrite file division in read_restart_snapshot_h5(). Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 119 ++++++++++++++++++++++++++++--------------------- 1 file changed, 67 insertions(+), 52 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index c91cbfc..f3002cb 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -3080,7 +3080,7 @@ module io #ifdef MPI use mesh , only : redistribute_blocks #endif /* MPI */ - use mpitools, only : nprocs, npmax, nproc + use mpitools, only : nprocs, nproc implicit none @@ -3088,7 +3088,7 @@ module io character(len=255) :: fname integer(hid_t) :: file_id, grp_id - integer :: nfiles, last_id, n + integer :: nfiles, last_id, n, i, nd, nr, nl, nu, il, iu logical :: flag real(kind=8) :: deinj @@ -3139,7 +3139,7 @@ module io ! larger or equal to the number of files, and when we have less processors than ! files ! - if (nproc < nfiles) then + if (nfiles <= nprocs .and. nproc < nfiles) then write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, nproc inquire(file=fname, exist=flag) @@ -3179,70 +3179,85 @@ module io call print_message(loc, "Could not close '" // trim(fname) // "'!") return end if + end if ! nproc < nfiles -#ifdef MPI -! if there are more files than processes, read the remaining files by -! the last process and redistribute blocks after each processed file, -! otherwise only redistribute blocks +! if there are more files than processes, divide the files equally between +! processes ! if (nprocs < nfiles) then - do n = nprocs, nfiles - 1 - call change_blocks_process(n, npmax) + nl = 0 + nd = nfiles / nprocs + nr = mod(nfiles, nprocs) + do n = 0, nprocs - 1 + if (n < nr) then + il = n * (nd + 1) + iu = il + nd + else + il = n * nd + nr + iu = il + nd - 1 + end if + do i = il, iu + call change_blocks_process(i, n) + end do + if (n == nproc) then + nl = il + nu = iu + end if + end do - if (nproc == npmax) then - write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, n - inquire(file=fname, exist=flag) - if (.not. flag) then - call print_message(loc, & - "Restart snapshot '" // trim(fname) // "' not found!") - status = 1 - return - end if + do n = nl, nu - call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) - if (status /= 0) then - call print_message(loc, "Could not open '" // trim(fname) // "'!") - return - end if - - call restore_datablocks_h5(file_id, status) - if (status /= 0) & - call print_message(loc, & - "Could not restore datablocks from '" // trim(fname) // "'!") - - call h5gopen_f(file_id, 'attributes', grp_id, status) - if (status /= 0) then - call print_message(loc, "Could not open group 'attributes'!") - return - end if - call restore_attribute_h5(grp_id, 'einj', & - H5T_NATIVE_DOUBLE, 1, deinj, status) - if (status /= 0) & - call print_message(loc, "Could not get the injected energy!") - einj = einj + deinj - call h5gclose_f(grp_id, status) - if (status /= 0) & - call print_message(loc, "Could not close group 'attributes'!") - - call h5fclose_f(file_id, status) - if (status /= 0) then - call print_message(loc, "Could not close '" // trim(fname) // "'!") - return - end if + write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, n + inquire(file=fname, exist=flag) + if (.not. flag) then + call print_message(loc, & + "Restart snapshot '" // trim(fname) // "' not found!") + status = 1 + return end if - call redistribute_blocks(status) + call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) + if (status /= 0) then + call print_message(loc, "Could not open '" // trim(fname) // "'!") + return + end if + + call restore_datablocks_h5(file_id, status) + if (status /= 0) & + call print_message(loc, & + "Could not restore datablocks from '" // trim(fname) // "'!") + + call h5gopen_f(file_id, 'attributes', grp_id, status) + if (status /= 0) then + call print_message(loc, "Could not open group 'attributes'!") + return + end if + call restore_attribute_h5(grp_id, 'einj', & + H5T_NATIVE_DOUBLE, 1, deinj, status) + if (status /= 0) & + call print_message(loc, "Could not get the injected energy!") + einj = einj + deinj + call h5gclose_f(grp_id, status) + if (status /= 0) & + call print_message(loc, "Could not close group 'attributes'!") + + call h5fclose_f(file_id, status) + if (status /= 0) then + call print_message(loc, "Could not close '" // trim(fname) // "'!") + return + end if end do - else - call redistribute_blocks(status) end if -#endif /* MPI */ if (allocated(block_array)) deallocate(block_array) +#ifdef MPI + call redistribute_blocks(status) +#endif /* MPI */ + !------------------------------------------------------------------------------- ! end subroutine read_restart_snapshot_h5 From a364281184c5d10339c6acff8b12e5e287a4ad48 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 18:17:29 -0300 Subject: [PATCH 19/25] IO: Fix restore_metablocks_h5() for 3D. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sources/io.F90 b/sources/io.F90 index f3002cb..c6a2c02 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -3904,7 +3904,7 @@ module io #if NDIMS == 3 l = rank(faces) dims(1:l) = shape(faces) - call store_dataset_h5(grp_id, 'faces', & + call read_dataset_h5(grp_id, 'faces', & H5T_NATIVE_INTEGER, dims(1:l), faces, status) #endif /* NDIMS == 3 */ l = rank(edges) From 80b9c6d6a21c50d9c2fb760dac74b58c8a8e97b4 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 18:59:21 -0300 Subject: [PATCH 20/25] IO: Compress only variable datasets in HDF5 regular snapshots. Do not compress HDF5 restart snapshots at all. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 97 +++++++++++++++++++++++++++++--------------------- 1 file changed, 56 insertions(+), 41 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index c6a2c02..1e730af 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -3757,13 +3757,13 @@ module io allocate(array(nmodes,NDIMS), stat=status) if (status == 0) then array = real(fcoefs) - call store_dataset_h5(grp_id, 'fcoefs_real', H5T_NATIVE_DOUBLE, & - dims, array, status) + call store_dataset_h5(grp_id, 'fcoefs_real', H5T_NATIVE_DOUBLE, & + dims, array, .false., status) if (status < 0) & call print_message(loc, "Could not store real(fcoefs)!") array = aimag(fcoefs) - call store_dataset_h5(grp_id, 'fcoefs_imag', H5T_NATIVE_DOUBLE, & - dims, array, status) + call store_dataset_h5(grp_id, 'fcoefs_imag', H5T_NATIVE_DOUBLE, & + dims, array, .false., status) if (status < 0) & call print_message(loc, "Could not store imag(fcoefs)!") deallocate(array, stat=status) @@ -3791,7 +3791,7 @@ module io if (status == 0) then call get_seeds(seeds) call store_dataset_h5(grp_id, 'seeds', H5T_STD_I64LE, & - dims, seeds, status) + dims, seeds, .false., status) if (status < 0) & call print_message(loc, "Could not store seeds!") deallocate(seeds, stat=status) @@ -4168,30 +4168,30 @@ module io l = rank(fields) dims(1:l) = shape(fields) - call store_dataset_h5(grp_id, 'fields', & - H5T_NATIVE_INTEGER, dims(1:l), fields, status) + call store_dataset_h5(grp_id, 'fields', H5T_NATIVE_INTEGER, & + dims(1:l), fields, .false., status) l = rank(children) dims(1:l) = shape(children) - call store_dataset_h5(grp_id, 'children', & - H5T_NATIVE_INTEGER, dims(1:l), children, status) + call store_dataset_h5(grp_id, 'children', H5T_NATIVE_INTEGER, & + dims(1:l), children, .false., status) #if NDIMS == 3 l = rank(faces) dims(1:l) = shape(faces) - call store_dataset_h5(grp_id, 'faces', & - H5T_NATIVE_INTEGER, dims(1:l), faces, status) + call store_dataset_h5(grp_id, 'faces', H5T_NATIVE_INTEGER, & + dims(1:l), faces, .false., status) #endif /* NDIMS == 3 */ l = rank(edges) dims(1:l) = shape(edges) - call store_dataset_h5(grp_id, 'edges', & - H5T_NATIVE_INTEGER, dims(1:l), edges, status) + call store_dataset_h5(grp_id, 'edges', H5T_NATIVE_INTEGER, & + dims(1:l), edges, .false., status) l = rank(corners) dims(1:l) = shape(corners) - call store_dataset_h5(grp_id, 'corners', & - H5T_NATIVE_INTEGER, dims(1:l), corners, status) + call store_dataset_h5(grp_id, 'corners', H5T_NATIVE_INTEGER, & + dims(1:l), corners, .false., status) l = rank(bounds) dims(1:l) = shape(bounds) - call store_dataset_h5(grp_id, 'bounds', & - H5T_NATIVE_DOUBLE, dims(1:l), bounds, status) + call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, & + dims(1:l), bounds, .false., status) #if NDIMS == 3 deallocate(fields, children, bounds, faces, & @@ -4441,13 +4441,13 @@ module io cdims = shape(pdata%uu) call store_dataset_h5(blk_id, 'primitive_variables', & - H5T_NATIVE_DOUBLE, pdims, pdata%q, status) + H5T_NATIVE_DOUBLE, pdims, pdata%q, .false., status) if (status /= 0) & call print_message(loc, & "Could not store the primitive variables in " // & trim(blk_name) // "!") call store_dataset_h5(blk_id, 'conservative_variables', & - H5T_NATIVE_DOUBLE, cdims, pdata%uu, status) + H5T_NATIVE_DOUBLE, cdims, pdata%uu, .false., status) if (status /= 0) & call print_message(loc, & "Could not store the conservative variables in " // & @@ -4533,10 +4533,13 @@ module io end if am(1) = toplev - call store_dataset_h5(grp_id, 'dx', H5T_NATIVE_DOUBLE, am, adx, status) - call store_dataset_h5(grp_id, 'dy', H5T_NATIVE_DOUBLE, am, ady, status) + call store_dataset_h5(grp_id, 'dx', H5T_NATIVE_DOUBLE, & + am, adx, .false., status) + call store_dataset_h5(grp_id, 'dy', H5T_NATIVE_DOUBLE, & + am, ady, .false., status) #if NDIMS == 3 - call store_dataset_h5(grp_id, 'dz', H5T_NATIVE_DOUBLE, am, adz, status) + call store_dataset_h5(grp_id, 'dz', H5T_NATIVE_DOUBLE, & + am, adz, .false., status) #endif /* NDIMS == 3 */ if (get_dblocks() > 0) then @@ -4575,14 +4578,14 @@ module io pdata => pdata%next end do - call store_dataset_h5(grp_id, 'ids', & - H5T_NATIVE_INTEGER, im, ids, status) - call store_dataset_h5(grp_id, 'levels', & - H5T_NATIVE_INTEGER, im, levels, status) - call store_dataset_h5(grp_id, 'coords', & - H5T_NATIVE_INTEGER, cm, coords, status) - call store_dataset_h5(grp_id, 'bounds', & - H5T_NATIVE_DOUBLE, bm, bounds, status) + call store_dataset_h5(grp_id, 'ids', H5T_NATIVE_INTEGER, & + im, ids, .false., status) + call store_dataset_h5(grp_id, 'levels', H5T_NATIVE_INTEGER, & + im, levels, .false., status) + call store_dataset_h5(grp_id, 'coords', H5T_NATIVE_INTEGER, & + cm, coords, .false., status) + call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, & + bm, bounds, .false., status) deallocate(ids, levels, coords, bounds, stat=status) if (status > 0) & @@ -4669,7 +4672,7 @@ module io end do call store_dataset_h5(grp_id, trim(pvars(p)), & - H5T_NATIVE_DOUBLE, dims, array, status) + H5T_NATIVE_DOUBLE, dims, array, .true., status) end do deallocate(array, stat=status) @@ -5238,16 +5241,18 @@ module io ! ! Arguments: ! -! loc_id - the location in which the dataset is stored; -! name - the dataset name; -! type_id - the dataset type; -! dims - the dataset dimensions; -! buffer - the dataset buffer to store; -! status - the subroutine call status; +! loc_id - the location in which the dataset is stored; +! name - the dataset name; +! type_id - the dataset type; +! dims - the dataset dimensions; +! buffer - the dataset buffer to store; +! compress - the logical flag inficating is dataset should be compressed; +! status - the subroutine call status; ! !=============================================================================== ! - subroutine store_dataset_h5(loc_id, name, type_id, dims, buffer, status) + subroutine store_dataset_h5(loc_id, name, type_id, dims, & + buffer, compress, status) use helpers , only : print_message use iso_c_binding, only : c_loc @@ -5258,16 +5263,22 @@ module io character(len=*) , intent(in) :: name integer(hsize_t), dimension(:), intent(in) :: dims type(*), target, dimension(..), intent(in) :: buffer + logical , intent(in) :: compress integer , intent(out) :: status integer :: rank integer(hid_t) :: space_id, dset_id + integer(hsize_t), dimension(size(dims)) :: cdims + character(len=*), parameter :: loc = 'IO::store_dataset_h5()' !------------------------------------------------------------------------------- ! - rank = size(dims) + cdims = dims + rank = size(dims) + + if (compress) cdims(1) = 1 call h5screate_simple_f(rank, dims, space_id, status) if (status /= 0) then @@ -5275,14 +5286,18 @@ module io "Could not create the dataspace for dataset '" // trim(name) // "'!") return end if - call h5pset_chunk_f(prp_id, rank, dims, status) + call h5pset_chunk_f(prp_id, rank, cdims, status) if (status /= 0) then call print_message(loc, & "Could not set the chunk size for dataset '" // trim(name) // "'!") go to 1000 end if - call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status, prp_id) + if (compress) then + call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status, prp_id) + else + call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status) + end if if (status /= 0) then call print_message(loc, & "Could not create dataset '" // trim(name) // "'!") From c85831a3869e0fc7734cf9e4d3073a60d6460d6b Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 19:00:24 -0300 Subject: [PATCH 21/25] IO: Rewrite HDF5 compression code and add ZFP compression. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 125 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 89 insertions(+), 36 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 1e730af..216a952 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -122,18 +122,24 @@ module io integer, save :: hash_length = 0 #ifdef HDF5 -! compression type +! supported compression types ! - integer , parameter :: H5Z_DEFLATE = 1, H5Z_ZSTANDARD = 32015 + integer, parameter :: H5Z_DEFLATE = 1, H5Z_ZFP = 32013, H5Z_ZSTANDARD = 32015 -! compression type (0 for no compressions, 1 for deflate, 32015 for zstandard) +! used compression type and level ! - integer , save :: compression = 0, hclevel = 3 + integer, save :: hcformat = 0, hclevel = 20 + +! ZFP compressor parameters +! + character(len=32), save :: zfpmode = "reversible" + integer , save :: zfpprec = 64 + real(kind=8) , save :: zfprate = 6.4d+01 + real(kind=8) , save :: zfpaccu = 0.0d+00 ! HDF5 property object identifier ! - integer(hid_t) , save :: prp_id - + integer(hid_t), save :: prp_id #endif /* HDF5 */ ! array of pointer used during job restart @@ -193,9 +199,8 @@ module io character(len=255) :: xdmf = "off" character(len=8) :: dtype = "xxh64" #ifdef HDF5 - logical :: cmpstatus = .false. - integer(hsize_t) :: cd_nelmts = 1 - integer, dimension(1) :: cd_values = 3 + integer(hsize_t) :: cd_nelmts = 6 + integer, dimension(6) :: cd_values = 0 #endif /* HDF5 */ #ifdef HDF5 @@ -304,31 +309,68 @@ module io "Cannot create the compression property for datasets!") else - cmpstatus = .false. - if (.not. cmpstatus) then - call h5zfilter_avail_f(H5Z_ZSTANDARD, cmpstatus, status) - if (cmpstatus) compression = H5Z_ZSTANDARD - end if - if (.not. cmpstatus) then - call h5zfilter_avail_f(H5Z_DEFLATE, cmpstatus, status) - if (cmpstatus) compression = H5Z_DEFLATE - end if + call get_parameter("compression_format", sformat) + call get_parameter("compression_level" , hclevel) + call get_parameter("zfp_mode" , zfpmode) + call get_parameter("zfp_rate" , zfprate) + call get_parameter("zfp_precision" , zfpprec) + call get_parameter("zfp_accuracy" , zfpaccu) - call get_parameter("compression_level", hclevel) + select case(sformat) + case("deflate", "gzip") + call h5zfilter_avail_f(H5Z_DEFLATE, test, status) + if (status == 0) then + if (test) then + hcformat = H5Z_DEFLATE + hclevel = max(1, min(9, hclevel)) + call h5pset_deflate_f(prp_id, hclevel, status) + end if + else + call print_message(loc, & + "Could not check if the filter is available!") + end if + case("zstd", "zstandard") + call h5zfilter_avail_f(H5Z_ZSTANDARD, test, status) + if (status == 0) then + if (test) then + hcformat = H5Z_ZSTANDARD + hclevel = max(1, min(20, hclevel)) + cd_values(:) = hclevel + call h5pset_filter_f(prp_id, H5Z_ZSTANDARD, & + H5Z_FLAG_OPTIONAL_F, cd_nelmts, cd_values, status) + end if + else + call print_message(loc, & + "Could not check if the filter is available!") + end if + case("zfp") + call h5zfilter_avail_f(H5Z_ZFP, test, status) + if (status == 0) then + if (test) then + hcformat = H5Z_ZFP + select case(trim(zfpmode)) + case('rate') + cd_values(1) = 1 + cd_values(3:4) = transfer(zfprate, [0_4]) + case('precision') + cd_values(1) = 2 + cd_values(3) = zfpprec + case('accuracy') + cd_values(1) = 3 + cd_values(3:4) = transfer(zfpaccu, [0_4]) + case('reversible') + cd_values(1) = 5 + end select + call h5pset_filter_f(prp_id, H5Z_ZFP, 0, & + cd_nelmts, cd_values, status) + end if + else + call print_message(loc, & + "Could not check if the filter is available!") + end if + case default + end select - if (status == 0) then - select case(compression) - case(H5Z_ZSTANDARD) - hclevel = max(1, min(20, hclevel)) - cd_values(:) = hclevel - call h5pset_filter_f(prp_id, H5Z_ZSTANDARD, H5Z_FLAG_OPTIONAL_F, & - cd_nelmts, cd_values, status) - case(H5Z_DEFLATE) - hclevel = max(1, min(9, hclevel)) - call h5pset_deflate_f(prp_id, hclevel, status) - case default - end select - end if end if end if #endif /* HDF5 */ @@ -434,13 +476,24 @@ module io call print_parameter(verbose, "precise snapshot intervals", & precise_snapshots, "on") #ifdef HDF5 - select case(compression) - case(H5Z_ZSTANDARD) - call print_parameter(verbose, "HDF5 compression" , "zstd" ) - call print_parameter(verbose, "compression level", hclevel ) + select case(hcformat) case(H5Z_DEFLATE) call print_parameter(verbose, "HDF5 compression" , "deflate") call print_parameter(verbose, "compression level", hclevel ) + case(H5Z_ZSTANDARD) + call print_parameter(verbose, "HDF5 compression" , "zstd" ) + call print_parameter(verbose, "compression level", hclevel ) + case(H5Z_ZFP) + call print_parameter(verbose, "HDF5 compression" , "zfp") + call print_parameter(verbose, "ZFP mode", zfpmode) + select case(trim(zfpmode)) + case('rate') + call print_parameter(verbose, "ZFP rate" , zfprate) + case('precision') + call print_parameter(verbose, "ZFP precision", zfpprec) + case('accuracy') + call print_parameter(verbose, "ZFP accuracy" , zfpaccu) + end select case default call print_parameter(verbose, "HDF5 compression" , "none" ) end select From 1664a37e10064a5080406f73cd258a5939ca6069 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 21:36:29 -0300 Subject: [PATCH 22/25] Update README.md Signed-off-by: Grzegorz Kowal --- README.md | 99 +++++++++++++++++++++++++++---------------------------- 1 file changed, 49 insertions(+), 50 deletions(-) diff --git a/README.md b/README.md index a1f3e3e..56c10d2 100644 --- a/README.md +++ b/README.md @@ -12,23 +12,26 @@ following features are already implemented: * hydrodynamic and magnetohydrodynamic set of equations (HD and MHD), * both classical and special relativity cases for the above equations, -* Cartesian coordinate system, +* Cartesian coordinate system so far, * uniform and adaptive mesh generation and update, -* 2nd to 4th order time integration using Strong Stability Preserving - Runge-Kutta methods, -* 2nd order TVD interpolation with number of limiters and higher order - reconstructions, +* a number of time integration methods, from 2nd to 5th order Runge-Kutta + methods: Strong Stability Preserving and Embedded (with the error control), +* high order reconstructions: from 2nd to 9th order WENO and MP, both explicit + and compact methods, the 2nd order TVD interpolation has a number of limiters + supported, * Riemann solvers of Roe- and HLL-types (HLL, HLLC, and HLLD), * standard boundary conditions: periodic, open, reflective, hydrostatic, etc. * turbulence driving using Alvelius or Ornstein–Uhlenbeck methods, * viscous and resistive source terms, -* support for passive scalars (up to 100), -* data stored in internal XML+binary or HDF5 format, -* support for Zstandard, LZ4, and LZMA compression in XML+binary format, -* Python interface to read snapshots in both formats, +* support for passive scalars, +* data stored in an internal XML+binary or the HDF5 format, +* data integrity of the XML+binary format guaranteed by the XXH64 or XXH3 hashes; +* support for Zstandard, LZ4, and LZMA compressions in the XML+binary format, +* support for Deflate, Zstandard, and ZFP compressions in the HDF5 format, +* easy and consistend Python interface to read snapshots in both formats, * MPI parallelization, * completely written in Fortran 2008, -* simple Makefile or CMake for executable building, +* simple Makefile or CMake for building the code executable, * minimum requirements, only Fortran compiler and Python are required to prepare, run, and analyze your simulations. @@ -62,63 +65,58 @@ Requirements compiler version 9.0 or newer. - [NVIDIA HPC](https://developer.nvidia.com/hpc-sdk) compiler version 21.9. Warning: I could not make it run with the included MPI libraries. -* Optional, but recommended, [OpenMPI](https://www.open-mpi.org/) for parallel - runs, tested with version 1.8 or newer. -* Optional support for XML-binary format compression requires: +* Recommended, although optional, [OpenMPI](https://www.open-mpi.org/) for + parallel runs, tested with version 1.8 or newer. +* Optional [CMake](https://cmake.org) version 3.16 or newer, for advanced + compilation option selection. +* Optionally, the XML-binary format compression requires: [LZ4 library](https://lz4.github.io), [Zstandard library](http://facebook.github.io/zstd/), or [LZMA library](https://tukaani.org/xz/) + [XXHASH library](http://www.xxhash.com/). * Optional [HDF5 libraries](https://www.hdfgroup.org/solutions/hdf5/), tested with version 1.10 or newer. The code now uses the new XML-binary snapshot format. However, if you still want to use older HDF5 snapshot format, you will need these libraries. -* Optional [CMake](https://cmake.org) version 3.16 or newer, for managing the - build process. - - -Environment Variables -===================== - -If you need to use the HDF5 libraries and they are not installed in the default -location, i.e. in the system directory **/usr**, make sure that the environment -variable _HDF5DIR_ is set in your **~/.bashrc** (or **~/.cshrc**) and pointing -to the location where the HDF5 libraries have been installed. +* Deflate compression is natively supported in HDF5 libraries, however, + optionally these compression formats are supported through filters: + [HDF5Plugin-Zstandard](https://github.com/gkowal/HDF5Plugin-Zstandard), + [H5Z-ZFP](https://github.com/LLNL/H5Z-ZFP). Recommended compilation (using CMake) ===================================== 1. Clone the AMUN source code: - - from Bitbucket: - `git clone https://grzegorz_kowal@bitbucket.org/amunteam/amun-code.git`, - from GitLab: `git clone https://gitlab.com/gkowal/amun-code.git` + - from Bitbucket: + `git clone https://grzegorz_kowal@bitbucket.org/amunteam/amun-code.git`, - or unpack the archive downloaded from page [Downloads](https://bitbucket.org/amunteam/amun-code/downloads/). -2. Create a directory for compilation in any location, - e.g. `mkdir cmake-build && cmake-build`. +2. Create the build directory, e.g. `mkdir amun-build && cd amun-build`. 3. Call `ccmake `, e.g. `ccmake ..`, and press 'c' once. - Configure available options. Press 'c' once again, and 'g' to - generate makefiles. Alternatively, just call `ccmake ` - for default options. + Set available options, if necessary. Press 'c' once again, and 'g' to + generate makefiles. 4. Compile the code using `make`. The executable file **amun.x** should be - created. + available in a few moments. -Alternative compilation (using `make.conf`) +Alternative compilation (using `make`) =========================================== 1. Clone the AMUN source code: - - from Bitbucket: - `git clone https://grzegorz_kowal@bitbucket.org/amunteam/amun-code.git`, - from GitLab: `git clone https://gitlab.com/gkowal/amun-code.git` + - from Bitbucket: + `git clone https://grzegorz_kowal@bitbucket.org/amunteam/amun-code.git`, - or unpack the archive downloaded from page [Downloads](https://bitbucket.org/amunteam/amun-code/downloads/). -2. Go to directory **build/hosts/** and copy file **default** to a new file named - exactly as your host name, i.e. `cp default $HOSTNAME`. +2. Go to directory **build/hosts/** and copy file **default** to a new file + named exactly as your host name, i.e. `cp default $HOSTNAME`. 3. Customize your compiler and compilation options in your new host file. -4. Go up to directory **build/** and copy file **make.default** to **make.config**. +4. Go up to the directory **build/** and copy file **make.default** to + **make.config**. 5. Customize compilation time options in **make.config**. 6. Compile sources by typing `make` in directory **build/**. The executable file **amun.x** should be created there. @@ -147,23 +145,24 @@ where N is the number of processors to use. Reading data ============ -By default, the code uses new XML+binary snapshot data format. It can also be -forced by setting parameter **snapshot_format** to **xml**. +By default, the code uses the new XML+binary snapshot data format. Parameter +**snapshot_format** set to either **xml** or **h5** controls which file format +is used. -In order to read produced data in this format, you will need to install the -provided Python module. Simply change to **python/** directory and run - `python setup.py install --user` +In order to read the data produced in this format, you will need to install the +Python module AmunPy included in subdirectory **python/amunpy**. Simply go to +this directory and run + `python ./setup.py install --user` to install the module in your home directory. Import the module in your python script using `from amunpy import *`, -and then initiate the interface using +and then initiate the interface to the XML+binary snapshots using `snapshot = AmunXML()` -and read desired variable using +or to the HDF5 files using + `snapshot = AmunH5()` +and read desired variables using function `var = snapshot.dataset()`. -The function **dataset()** returns rescaled uniform mesh variable as NumPy -array. - -If you want to read data from HDF5 snapshot, just use - `var = amun_dataset(, )`. +The function **dataset()** returns the requested variable mapped on the uniform +mesh as a NumPy array. From 43ad4a7af34384cd1b38220a62921037dc2dcf70 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Wed, 1 Dec 2021 21:52:41 -0300 Subject: [PATCH 23/25] IO: Add SZIP compression to HDF5 snapshots. Signed-off-by: Grzegorz Kowal --- README.md | 3 ++- sources/io.F90 | 30 +++++++++++++++++++++++------- 2 files changed, 25 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 56c10d2..e06a553 100644 --- a/README.md +++ b/README.md @@ -27,7 +27,7 @@ following features are already implemented: * data stored in an internal XML+binary or the HDF5 format, * data integrity of the XML+binary format guaranteed by the XXH64 or XXH3 hashes; * support for Zstandard, LZ4, and LZMA compressions in the XML+binary format, -* support for Deflate, Zstandard, and ZFP compressions in the HDF5 format, +* support for Deflate, SZIP, Zstandard, and ZFP compressions in the HDF5 format, * easy and consistend Python interface to read snapshots in both formats, * MPI parallelization, * completely written in Fortran 2008, @@ -80,6 +80,7 @@ Requirements will need these libraries. * Deflate compression is natively supported in HDF5 libraries, however, optionally these compression formats are supported through filters: + [SZIP](https://support.hdfgroup.org/doc_resource/SZIP/) [HDF5Plugin-Zstandard](https://github.com/gkowal/HDF5Plugin-Zstandard), [H5Z-ZFP](https://github.com/LLNL/H5Z-ZFP). diff --git a/sources/io.F90 b/sources/io.F90 index 216a952..7cba9e2 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -124,7 +124,10 @@ module io #ifdef HDF5 ! supported compression types ! - integer, parameter :: H5Z_DEFLATE = 1, H5Z_ZFP = 32013, H5Z_ZSTANDARD = 32015 + integer, parameter :: H5Z_DEFLATE = 1 + integer, parameter :: H5Z_SZIP = 4 + integer, parameter :: H5Z_ZFP = 32013 + integer, parameter :: H5Z_ZSTANDARD = 32015 ! used compression type and level ! @@ -329,6 +332,17 @@ module io call print_message(loc, & "Could not check if the filter is available!") end if + case("szip") + call h5zfilter_avail_f(H5Z_FILTER_SZIP_F, test, status) + if (status == 0) then + if (test) then + hcformat = H5Z_SZIP + call h5pset_szip_f(prp_id, 32, 32, status) + end if + else + call print_message(loc, & + "Could not check if the filter is available!") + end if case("zstd", "zstandard") call h5zfilter_avail_f(H5Z_ZSTANDARD, test, status) if (status == 0) then @@ -478,13 +492,15 @@ module io #ifdef HDF5 select case(hcformat) case(H5Z_DEFLATE) - call print_parameter(verbose, "HDF5 compression" , "deflate") - call print_parameter(verbose, "compression level", hclevel ) + call print_parameter(verbose, "HDF5 compression", "deflate") + call print_parameter(verbose, "compression level", hclevel) + case(H5Z_SZIP) + call print_parameter(verbose, "HDF5 compression", "szip") case(H5Z_ZSTANDARD) - call print_parameter(verbose, "HDF5 compression" , "zstd" ) - call print_parameter(verbose, "compression level", hclevel ) + call print_parameter(verbose, "HDF5 compression", "zstd") + call print_parameter(verbose, "compression level", hclevel) case(H5Z_ZFP) - call print_parameter(verbose, "HDF5 compression" , "zfp") + call print_parameter(verbose, "HDF5 compression", "zfp") call print_parameter(verbose, "ZFP mode", zfpmode) select case(trim(zfpmode)) case('rate') @@ -495,7 +511,7 @@ module io call print_parameter(verbose, "ZFP accuracy" , zfpaccu) end select case default - call print_parameter(verbose, "HDF5 compression" , "none" ) + call print_parameter(verbose, "HDF5 compression" , "none") end select call print_parameter(verbose, "generate XDMF files", with_xdmf, "on") #endif /* HDF5 */ From ce1f6cee4a9a23da73da0a13695d589981a6bfc0 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Thu, 2 Dec 2021 09:15:35 -0300 Subject: [PATCH 24/25] IO: Tune chunking for compressions in store_dataset_h5(). Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 7cba9e2..1f53308 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -5344,10 +5344,9 @@ module io !------------------------------------------------------------------------------- ! - cdims = dims rank = size(dims) - - if (compress) cdims(1) = 1 + cdims = dims + if (compress .and. hcformat .eq. H5Z_ZFP) cdims(rank) = 1 call h5screate_simple_f(rank, dims, space_id, status) if (status /= 0) then From 5792fe60a0afa3eb065ebdafb0d14d9fdace887f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Thu, 2 Dec 2021 10:43:03 -0300 Subject: [PATCH 25/25] IO: Store data type and dimensions for XML-binary format. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 73 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 25 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index 1f53308..07f2233 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -2148,40 +2148,50 @@ module io write(fname,"(a,'.bin')") "metablock_fields" bytes = size(fields, kind=8) * kind(fields) call write_binary_xml(dname, fname, c_loc(fields), bytes, dtype, digest) - call write_attribute_xml(lun, "fields", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "fields", fname, 'int32', & + shape(fields), bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_children" bytes = size(children, kind=8) * kind(children) - call write_binary_xml(dname, fname, c_loc(children), bytes, dtype, digest) - call write_attribute_xml(lun, "children", fname, bytes, dtype, digest) + call write_binary_xml(dname, fname, c_loc(children), & + bytes, dtype, digest) + call write_attribute_xml(lun, "children", fname, 'int32', & + shape(children), bytes, dtype, digest) #if NDIMS == 3 write(fname,"(a,'.bin')") "metablock_faces" bytes = size(faces, kind=8) * kind(faces) call write_binary_xml(dname, fname, c_loc(faces), bytes, dtype, digest) - call write_attribute_xml(lun, "faces", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "faces", fname, 'int32', & + shape(faces), bytes, dtype, digest) #endif /* NDIMS == 3 */ write(fname,"(a,'.bin')") "metablock_edges" bytes = size(edges, kind=8) * kind(edges) call write_binary_xml(dname, fname, c_loc(edges), bytes, dtype, digest) - call write_attribute_xml(lun, "edges", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "edges", fname, 'int32', & + shape(edges), bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_corners" bytes = size(corners, kind=8) * kind(corners) - call write_binary_xml(dname, fname, c_loc(corners), bytes, dtype, digest) - call write_attribute_xml(lun, "corners", fname, bytes, dtype, digest) + call write_binary_xml(dname, fname, c_loc(corners), & + bytes, dtype, digest) + call write_attribute_xml(lun, "corners", fname, 'int32', & + shape(corners), bytes, dtype, digest) write(fname,"(a,'.bin')") "metablock_bounds" bytes = size(bounds, kind=8) * kind(bounds) call write_binary_xml(dname, fname, c_loc(bounds), bytes, dtype, digest) - call write_attribute_xml(lun, "bounds", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "bounds", fname, 'float64', & + shape(bounds), bytes, dtype, digest) if (nmodes > 0) then write(fname,"(a,'.bin')") "forcing_coefficients" bytes = size(fcoefs, kind=8) * kind(fcoefs) - call write_binary_xml(dname, fname, c_loc(fcoefs), bytes, dtype, digest) - call write_attribute_xml(lun, "forcing", fname, bytes, dtype, digest) + call write_binary_xml(dname, fname, c_loc(fcoefs), & + bytes, dtype, digest) + call write_attribute_xml(lun, "forcing", fname, 'complex64', & + shape(fcoefs), bytes, dtype, digest) end if #if NDIMS == 3 @@ -2246,14 +2256,14 @@ module io call write_binary_xml(dname, fname, c_loc(pdata%q), & bytes, dtype, digest) call write_attribute_xml(lun, "prim" // trim(aname), fname, & - bytes, dtype, digest) + 'float64', shape(pdata%q), bytes, dtype, digest) write(fname,"('datablock_cons_',i6.6,a,'.bin')") nproc, trim(aname) bytes = size(pdata%uu, kind=8) * kind(pdata%uu) call write_binary_xml(dname, fname, c_loc(pdata%uu), & bytes, dtype, digest) call write_attribute_xml(lun, "cons" // trim(aname), fname, & - bytes, dtype, digest) + 'float64', shape(pdata%uu), bytes, dtype, digest) pdata => pdata%next @@ -2262,7 +2272,8 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc bytes = size(ids, kind=8) * kind(ids) call write_binary_xml(dname, fname, c_loc(ids), bytes, dtype, digest) - call write_attribute_xml(lun, "ids", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "ids", fname, 'int32', & + shape(ids), bytes, dtype, digest) if (allocated(ids)) deallocate(ids) @@ -2283,7 +2294,8 @@ module io write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc bytes = size(seeds, kind=8) * kind(seeds) call write_binary_xml(dname, fname, c_loc(seeds), bytes, dtype, digest) - call write_attribute_xml(lun, "seeds", fname, bytes, dtype, digest) + call write_attribute_xml(lun, "seeds", fname, 'int64', & + shape(seeds), bytes, dtype, digest) if (allocated(seeds)) deallocate(seeds) @@ -2491,15 +2503,15 @@ module io dbytes = size(fields, kind=8) * kind(fields) call write_binary_xml(dname, fname, c_loc(fields), & dbytes, hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "fields", fname, & - dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, "fields", fname, 'int32', & + shape(fields), dbytes, hash_type, ddigest, cbytes, cdigest) write(fname,"(a,'.bin')") "metablock_bounds" dbytes = size(bounds, kind=8) * kind(bounds) call write_binary_xml(dname, fname, c_loc(bounds), & dbytes, hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "bounds", fname, & - dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, "bounds", fname, 'float64', & + shape(bounds), dbytes, hash_type, ddigest, cbytes, cdigest) if (allocated(fields)) deallocate(fields) if (allocated(bounds)) deallocate(bounds) @@ -2558,7 +2570,7 @@ module io dbytes = size(ids, kind=8) * kind(ids) call write_binary_xml(dname, fname, c_loc(ids), & dbytes, hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, "ids", fname, & + call write_attribute_xml(lun, "ids", fname, 'int32', shape(ids), & dbytes, hash_type, ddigest, cbytes, cdigest) dbytes = size(array, kind=8) * kind(array) @@ -2578,8 +2590,8 @@ module io trim(pvars(p)), nproc call write_binary_xml(dname, fname, c_loc(array), & dbytes, hash_type, ddigest, cbytes, cdigest) - call write_attribute_xml(lun, pvars(p), fname, & - dbytes, hash_type, ddigest, cbytes, cdigest) + call write_attribute_xml(lun, pvars(p), fname, 'float64', & + shape(array), dbytes, hash_type, ddigest, cbytes, cdigest) end do if (allocated(ids)) deallocate(ids) @@ -2743,6 +2755,8 @@ module io ! lun - the file handler to write to; ! aname - the file attribute name; ! filename - the file name; +! data_type - the data type of the input data; +! data_shape - the shape of the input data; ! digest_string - the digest type string; ! data_bytes - the file size in bytes; ! data_digest - the digest of the file content; @@ -2751,8 +2765,9 @@ module io ! !=============================================================================== ! - subroutine write_attribute_xml_file(lun, aname, filename, data_bytes, & - digest_type, data_digest, & + subroutine write_attribute_xml_file(lun, aname, filename, & + data_type, data_shape, & + data_bytes, digest_type, data_digest, & compressed_bytes, compressed_digest) use compression, only : compression_suffix @@ -2761,20 +2776,28 @@ module io implicit none integer , intent(in) :: lun - character(len=*) , intent(in) :: aname, filename + character(len=*) , intent(in) :: aname, filename, data_type integer , intent(in) :: digest_type + integer, dimension(:) , intent(in) :: data_shape integer(kind=8) , intent(in) :: data_bytes, data_digest integer(kind=8) , optional, intent(in) :: compressed_bytes integer(kind=8) , optional, intent(in) :: compressed_digest character(len=256) :: fname character(len=1024) :: string - character(len=32) :: str + character(len=128) :: str + integer :: n !------------------------------------------------------------------------------- ! fname = filename string = '