attributes.f90 Source File


This file depends on

sourcefile~~attributes.f90~~EfferentGraph sourcefile~attributes.f90 attributes.f90 sourcefile~interface.f90 interface.f90 sourcefile~attributes.f90->sourcefile~interface.f90

Contents

Source Code


Source Code

submodule (h5fortran) 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

if(.not.self%is_open) error stop 'h5fortran:readattr: file handle is not open'

block
  character(len(attrval)) :: buf
  call h5ltget_attribute_string_f(self%lid, dname, attr, buf, ier)
  attrval = buf
end block

if (present(ierr)) ierr = ier
if (check(ier, self%filename, dname)) then
  if (present(ierr)) return
  error stop
endif

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) then
select type(attrval)
type is (real(real32))
  call h5ltget_attribute_float_f(self%lid, dname, attr, attrval, ier)
type is (real(real64))
  call h5ltget_attribute_double_f(self%lid, dname, attr, attrval, ier)
type is (integer(int32))
  call h5ltget_attribute_int_f(self%lid, dname, attr, attrval, ier)
class default
  ier = 6
end select
endif

if (present(ierr)) ierr = ier
if (check(ier, self%filename, dname)) then
  if (present(ierr)) return
  error stop
endif


end procedure readattr_num


module procedure writeattr_char
!! NOTE: HDF5 character attributes are scalar.

integer :: ier

if(.not.self%is_open) error stop 'h5fortran:writeattr: file handle is not open'

call h5ltset_attribute_string_f(self%lid, dname, attr, attrval, ier)

if (present(ierr)) ierr = ier
if (check(ier, self%filename, dname)) then
  if (present(ierr)) return
  error stop
endif

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 'h5fortran:writeattr: file handle is not open'

dsize = size(attrval)

select type(attrval)
type is (real(real32))
  call h5ltset_attribute_float_f(self%lid, dname, attr, attrval, dsize, ier)
type is (real(real64))
  call h5ltset_attribute_double_f(self%lid, dname, attr, attrval, dsize, ier)
type is (integer(int32))
  call h5ltset_attribute_int_f(self%lid, dname, attr, attrval, dsize, ier)
class default
  ier = 6
end select

if (present(ierr)) ierr = ier
if (check(ier, self%filename, dname)) then
  if (present(ierr)) return
  error stop
endif

end procedure writeattr_num


module procedure writeattr_char_lt

type(hdf5_file) :: h
integer :: ier

call h%open(filename, ier, status='old')

call h%writeattr_char(dname, attr, attrval, ier)

if (ier == 0) call h%close(ier)

if (present(ierr)) ierr = ier
if (check(ier, filename, dname)) then
  if (present(ierr)) return
  error stop
endif

end procedure writeattr_char_lt


module procedure writeattr_num_lt

type(hdf5_file) :: h
integer :: ier

call h%open(filename, ier, status='old')

call h%writeattr_num(dname, attr, attrval, ier)

if (ier == 0) call h%close(ier)

if (present(ierr)) ierr = ier
if (check(ier, filename, dname)) then
  if (present(ierr)) return
  error stop
endif

end procedure writeattr_num_lt


module procedure readattr_char_lt

type(hdf5_file) :: h
integer :: ier

call h%open(filename, ier, status='old')

call h%readattr_char(dname, attr, attrval, ier)

if (ier == 0) call h%close(ier)

if (present(ierr)) ierr = ier
if (check(ier, filename, dname) .and. .not. present(ierr)) error stop

end procedure readattr_char_lt


module procedure readattr_num_lt

type(hdf5_file) :: h
integer :: ier

call h%open(filename, ier, status='old')

call h%readattr_num(dname, attr, attrval, ier)

if (ier == 0) call h%close(ier)

if (present(ierr)) ierr = ier
if (check(ier, filename, dname) .and. .not. present(ierr)) error stop

end procedure readattr_num_lt


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
  write(stderr,*) 'ERROR: ' // dname // ' attribute ' // attr // ' does not exist in ' // self%filename
  ierr = -1
  return
endif

!> check for matching rank, else bad reads can occur--doesn't always crash without this check
call h5ltget_attribute_ndims_f(self%lid, dname, attr, arank, ierr)
if (check(ierr, 'ERROR:get_attribute_ndims: ' // dname // ' ' // self%filename)) return

if (arank /= 1) then
  write(stderr,'(A,I6,A,I6)') 'ERROR: attribute rank mismatch ' // dname // ' attribute "' // attr // '" = ', &
    arank,'  should be 1'
  ierr = -1
  return
endif

!> check for matching size, else bad reads can occur.

call h5ltget_attribute_info_f(self%lid, dname, attr, adims, atype, attr_bytes, ierr)
if (check(ierr, 'ERROR: get_attribute_info' // dname // ' read ' // self%filename)) return

if(.not. all(asize == adims)) then
  write(stderr,*) 'ERROR: shape mismatch ' // dname // ' attribute "' // attr //'" = ', adims,'  shape =', asize
  ierr = -1
  return
endif

end subroutine attr_shape_check


end submodule attributes