add read/write attributes

Author: scivision

src/CMakeLists.txt

@@ -5,6 +5,7 @@ configure_file(hdf5_config.in.f90 hdf5_config.f90 @ONLY)
 
 # main library
 add_library(h5mpi interface.f90
+attributes.f90
 ${CMAKE_CURRENT_BINARY_DIR}/hdf5_config.f90
 )
 target_link_libraries(h5mpi PRIVATE HDF5::HDF5 MPI::MPI_Fortran)

src/attributes.f90

@@ -0,0 +1,131 @@
+submodule (h5mpi) attributes
+
+use h5lt, only: h5ltset_attribute_string_f, h5ltset_attribute_float_f, h5ltset_attribute_double_f, h5ltset_attribute_int_f, &
+h5ltget_attribute_string_f, h5ltget_attribute_float_f, h5ltget_attribute_double_f, h5ltget_attribute_int_f, &
+h5ltget_attribute_ndims_f, h5ltget_attribute_info_f
+
+implicit none (type, external)
+
+
+contains
+
+
+module procedure readattr_char
+!! NOTE: HDF5 character attributes are scalar.
+integer :: ier
+character(len(attrval)) :: buf
+
+if(.not.self%is_open()) error stop 'h5fortran:readattr: file handle is not open'
+
+call h5ltget_attribute_string_f(self%file_id, dname, attr, buf, ier)
+if (ier /= 0) error stop "ERROR:h5fortran:readattr_char: problem reading attr of " // dname // " in " // self%filename
+
+attrval = buf
+
+end procedure readattr_char
+
+
+module procedure readattr_num
+!! NOTE: HDF5 has 1D vector attributes for integer, float and double.
+integer :: ier
+
+if(.not.self%is_open()) error stop 'h5fortran:readattr: file handle is not open'
+
+call attr_shape_check(self, dname, attr, size(attrval), ier)
+if (ier /= 0) error stop "ERROR:h5fortran:readattr_num: shape check attr of " // dname // " in " // self%filename
+
+select type(attrval)
+type is (real(real32))
+  call h5ltget_attribute_float_f(self%file_id, dname, attr, attrval, ier)
+type is (real(real64))
+  call h5ltget_attribute_double_f(self%file_id, dname, attr, attrval, ier)
+type is (integer(int32))
+  call h5ltget_attribute_int_f(self%file_id, dname, attr, attrval, ier)
+class default
+  error stop "ERROR:h5fortran:readattr_num: unknown dataset type for " // dname // " in " // self%filename
+end select
+
+if (ier /= 0) error stop "ERROR:h5fortran:readattr_num: " // dname // " in " // self%filename
+
+end procedure readattr_num
+
+
+module procedure writeattr_char
+!! NOTE: HDF5 character attributes are scalar.
+
+integer :: ier
+
+if(.not.self%is_open()) error stop 'ERROR:h5fortran:writeattr: file handle is not open'
+
+call h5ltset_attribute_string_f(self%file_id, dname, attr, attrval, ier)
+
+if (ier /= 0) error stop "ERROR:h5fortran:writeattr_char: " // dname // " in " // self%filename
+
+end procedure writeattr_char
+
+
+module procedure writeattr_num
+!! NOTE: HDF5 has 1D vector attributes for integer, float and double.
+integer :: ier
+integer(size_t) :: dsize
+
+if(.not.self%is_open()) error stop 'ERROR:h5fortran:writeattr: file handle is not open'
+
+dsize = size(attrval)
+
+select type(attrval)
+type is (real(real32))
+  call h5ltset_attribute_float_f(self%file_id, dname, attr, attrval, dsize, ier)
+type is (real(real64))
+  call h5ltset_attribute_double_f(self%file_id, dname, attr, attrval, dsize, ier)
+type is (integer(int32))
+  call h5ltset_attribute_int_f(self%file_id, dname, attr, attrval, dsize, ier)
+class default
+  error stop "ERROR:h5fortran:writeattr_num: unknown dataset type for " // dname // " in " // self%filename
+end select
+
+if (ier /= 0) error stop "ERROR:h5fortran:writeattr_num: " // dname // " in " // self%filename
+
+end procedure writeattr_num
+
+
+subroutine attr_shape_check(self, dname, attr, asize, ierr)
+class(hdf5_file), intent(in) :: self
+character(*), intent(in) :: dname, attr
+integer, intent(in) :: asize
+integer, intent(out) :: ierr
+
+integer :: arank, atype
+integer(size_t) :: attr_bytes
+integer(hsize_t) :: adims(1)
+
+if(.not. self%is_open()) error stop 'h5fortran:attr_shape: file handle is not open'
+
+if (.not. self%exist(dname)) then
+  error stop 'ERROR:h5fortran ' // dname // ' attribute ' // attr // ' does not exist in ' // self%filename
+endif
+
+!> check for matching rank, else bad reads can occur--doesn't always crash without this check
+call h5ltget_attribute_ndims_f(self%file_id, dname, attr, arank, ierr)
+if (ierr /= 0) error stop 'ERROR:h5fortran:get_attribute_ndims: ' // dname // ' ' // self%filename
+
+if (arank /= 1) then
+  write(stderr,'(A,I6,A,I6)') 'ERROR: attribute rank mismatch ' // dname // ' attribute "' // attr // '" = ', &
+    arank,'  should be 1'
+  error stop
+endif
+
+!> check for matching size, else bad reads can occur.
+
+call h5ltget_attribute_info_f(self%file_id, dname, attr, adims, atype, attr_bytes, ierr)
+if (ierr /= 0) error stop 'ERROR:h5fortran: get_attribute_info' // dname // ' read ' // self%filename
+
+if(.not. all(asize == adims)) then
+  write(stderr,*) 'ERROR:h5fortran: shape mismatch ' // dname // ' attribute "' // attr //'" = ', adims,'  shape =', asize
+  error stop
+endif
+
+end subroutine attr_shape_check
+
+
+end submodule attributes

src/interface.f90

@@ -65,7 +65,15 @@ module h5mpi
 generic, public :: read => h5read_scalar, ph5read_1d, ph5read_2d, ph5read_3d, ph5read_4d, ph5read_5d, ph5read_6d, ph5read_7d
 !! mapped procedures
 
-procedure,private :: h5write_scalar, ph5write_1d, ph5write_2d, ph5write_3d, ph5write_4d, ph5write_5d, ph5write_6d, ph5write_7d
+!> write attributes
+generic, public :: writeattr => writeattr_char, writeattr_num
+
+!> read attributes
+generic, public :: readattr => readattr_char, readattr_num
+
+procedure, private :: writeattr_char, writeattr_num, readattr_char, readattr_num
+
+procedure, private :: h5write_scalar, ph5write_1d, ph5write_2d, ph5write_3d, ph5write_4d, ph5write_5d, ph5write_6d, ph5write_7d
 
 procedure, private :: h5read_scalar, ph5read_1d, ph5read_2d, ph5read_3d, ph5read_4d, ph5read_5d, ph5read_6d, ph5read_7d
 !! mapped procedures must be declared again like this
@@ -84,7 +92,7 @@ module h5mpi
 
 private
 public :: mpi_h5comm, hdf5_file, mpi_tags, has_parallel_compression, is_hdf5, &
-check, hdf_rank_check, hdf_shape_check, mpi_collective, mpi_hyperslab, &
+hdf_rank_check, hdf_shape_check, mpi_collective, mpi_hyperslab, &
 hdf5version, h5exist, &
 HSIZE_T, &
 H5T_INTEGER_F, H5T_FLOAT_F, H5T_STRING_F, &
@@ -324,6 +332,37 @@ end subroutine ph5read_7d
 
 end interface
 
+
+interface  !< attributes.f90
+
+module subroutine readattr_char(self, dname, attr, attrval)
+class(hdf5_file), intent(in) :: self
+character(*), intent(in) :: dname, attr
+character(*), intent(inout) :: attrval
+!! intent(inout) for character
+end subroutine readattr_char
+
+module subroutine readattr_num(self, dname, attr, attrval)
+class(hdf5_file), intent(in) :: self
+character(*), intent(in) :: dname, attr
+class(*), intent(out) :: attrval(:)
+end subroutine readattr_num
+
+module subroutine writeattr_char(self, dname, attr, attrval)
+class(hdf5_file), intent(in) :: self
+character(*), intent(in) :: dname, attr
+character(*), intent(in) :: attrval
+end subroutine writeattr_char
+
+module subroutine writeattr_num(self, dname, attr, attrval)
+class(hdf5_file), intent(in) :: self
+character(*), intent(in) :: dname, attr
+class(*), intent(in) :: attrval(:)
+end subroutine writeattr_num
+
+end interface
+
+
 contains
 
 
@@ -731,26 +770,6 @@ subroutine hdf_flush(self)
 end subroutine hdf_flush
 
 
-logical function check(ierr, filename, dname)
-integer, intent(in) :: ierr
-character(*), intent(in), optional :: filename, dname
-
-character(:), allocatable :: fn, dn
-
-check = .false.
-if (ierr==0) return
-
-check = .true.
-fn = ""
-dn = ""
-if (present(filename)) fn = filename
-if (present(dname)) dn = dname
-
-write(stderr,*) 'ERROR: ' // fn // ':' // dn // ' error code ', ierr
-
-end function check
-
-
 logical function hdf_exist(self, dname) result(exists)
 class(hdf5_file), intent(in) :: self
 character(*), intent(in) :: dname

src/tests/unit/CMakeLists.txt

@@ -20,7 +20,7 @@ add_library(test_utils OBJECT utils.f90)
 
 # --- unit tests
 
-set(test_names cast deflate_write deflate_props deflate_read destructor exist groups layout shape string)
+set(test_names attributes cast deflate_write deflate_props deflate_read destructor exist groups layout shape string)
 
 foreach(t IN LISTS test_names)
 

src/tests/unit/test_attributes.f90

@@ -0,0 +1,89 @@
+program test_attributes
+
+use, intrinsic:: iso_fortran_env, only: int32, real32, real64, stderr=>error_unit
+
+use h5mpi, only: hdf5_file
+use mpi, only : mpi_init, MPI_COMM_WORLD, mpi_comm_rank
+
+implicit none (type, external)
+
+external :: mpi_finalize
+
+character(*), parameter :: filename = 'test_attr.h5'
+
+integer :: ierr, mpi_id
+
+call mpi_init(ierr)
+if (ierr /= 0) error stop "mpi_init"
+
+call mpi_comm_rank(MPI_COMM_WORLD, mpi_id, ierr)
+if (ierr /= 0) error stop "mpi_comm_rank"
+
+
+call test_write_attributes(filename)
+if(mpi_id == 0) print *,'PASSED: HDF5 write attributes'
+
+call test_read_attributes(filename)
+if(mpi_id == 0) print *, 'PASSED: HDF5 read attributes'
+
+
+call mpi_finalize(ierr)
+if (ierr /= 0) error stop "mpi_finalize"
+
+
+contains
+
+
+subroutine test_write_attributes(path)
+
+type(hdf5_file) :: h
+character(*), intent(in) :: path
+
+call h%open(path, action='w', mpi=.true.)
+
+call h%write('/x', 1)
+
+call h%writeattr('/x', 'note','this is just a little number')
+call h%writeattr('/x', 'hello', 'hi')
+call h%writeattr('/x', 'life', [42])
+call h%writeattr('/x', 'life_float', [42._real32, 84._real32])
+call h%writeattr('/x', 'life_double', [42._real64])
+
+call h%close()
+
+end subroutine test_write_attributes
+
+
+subroutine test_read_attributes(path)
+
+type(hdf5_file) :: h
+character(*), intent(in) :: path
+character(1024) :: attr_str
+integer :: attr_int(1)
+real(real32) :: attr32(2)
+real(real64) :: attr64(1)
+
+integer :: x
+
+call h%open(path, action='r', mpi=.true.)
+
+call h%read('/x', x)
+if (x/=1) error stop 'readattr: unexpected value'
+
+call h%readattr('/x', 'note', attr_str)
+if (attr_str /= 'this is just a little number') error stop 'readattr value note'
+
+call h%readattr('/x', 'life', attr_int)
+if (attr_int(1) /= 42) error stop 'readattr: int'
+
+call h%readattr('/x', 'life_float', attr32)
+if (any(attr32 /= [42._real32, 84._real32])) error stop 'readattr: real32'
+
+call h%readattr('/x', 'life_double', attr64)
+if (attr64(1) /= 42._real64) error stop 'readattr: real64'
+
+call h%close()
+
+end subroutine test_read_attributes
+
+end program