From 4ad32124a83af69647367107c6a0f9818c1cc10b Mon Sep 17 00:00:00 2001 From: "Michael Hirsch, Ph.D" Date: Tue, 3 Mar 2020 09:52:22 -0500 Subject: [PATCH] reduce redunancy and add write array rank mismatch check --- src/interface.f90 | 44 ++++--------- src/reader.f90 | 132 ++++++++++++++++++++++++--------------- src/tests/test_array.f90 | 28 ++++----- 3 files changed, 108 insertions(+), 96 deletions(-) diff --git a/src/interface.f90 b/src/interface.f90 index ea67476b..b5b1afad 100644 --- a/src/interface.f90 +++ b/src/interface.f90 @@ -536,57 +536,37 @@ subroutine hdf_shape_check(self, dname, dims, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname integer(HSIZE_T), intent(in) :: dims(:) -integer, intent(out), optional :: ierr +integer, intent(out) :: ierr integer(SIZE_T) :: dsize integer(HSIZE_T) :: ddims(size(dims)) -integer :: dtype, drank, ier +integer :: dtype, drank if (.not.self%exist(dname)) then write(stderr,*) 'ERROR: ' // dname // ' does not exist in ' // self%filename - if (present(ierr)) then - ierr = -1 - return - else - error stop - endif + ierr = -1 + return endif !> check for matching rank, else bad reads can occur--doesn't always crash without this check -call h5ltget_dataset_ndims_f(self%lid, dname, drank, ier) -if (present(ierr)) ierr = ier -if (check(ier, 'ERROR: get_dataset_ndim ' // dname // ' read ' // self%filename)) then - if (present(ierr)) return - error stop -endif +call h5ltget_dataset_ndims_f(self%lid, dname, drank, ierr) +if (check(ierr, 'ERROR: get_dataset_ndim ' // dname // ' read ' // self%filename)) return if (drank /= size(dims)) then write(stderr,'(A,I6,A,I6)') 'ERROR: rank mismatch ' // dname // ' = ',drank,' variable rank =', size(dims) - if (present(ierr)) then - ierr = -1 - return - else - error stop - endif + ierr = -1 + return endif !> check for matching size, else bad reads can occur. -call h5ltget_dataset_info_f(self%lid, dname, ddims, dtype, dsize, ier) -if (present(ierr)) ierr = ier -if (check(ier, 'ERROR: get_dataset_info ' // dname // ' read ' // self%filename)) then - if (present(ierr)) return - error stop -endif +call h5ltget_dataset_info_f(self%lid, dname, ddims, dtype, dsize, ierr) +if (check(ierr, 'ERROR: get_dataset_info ' // dname // ' read ' // self%filename)) return if(.not. all(dims == ddims)) then write(stderr,*) 'ERROR: shape mismatch ' // dname // ' = ',ddims,' variable shape =', dims - if (present(ierr)) then - ierr = -1 - return - else - error stop - endif + ierr = -1 + return endif end subroutine hdf_shape_check diff --git a/src/reader.f90 b/src/reader.f90 index e62e1f93..73448d07 100644 --- a/src/reader.f90 +++ b/src/reader.f90 @@ -24,24 +24,26 @@ ier = -1 endif +if (ier == 0) then select type (value) type is (character(*)) block character(len(value)) :: buf - if (ier == 0) call h5ltread_dataset_string_f(self%lid, dname, buf, ier) + call h5ltread_dataset_string_f(self%lid, dname, buf, ier) value = buf end block return type is (real(real64)) - if (ier == 0) call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) + call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) type is (real(real32)) - if (ier == 0) call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) + call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) type is (integer(int32)) - if (ier == 0) call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_INTEGER_KIND), value, dims, ier) + call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_INTEGER_KIND), value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -62,29 +64,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -105,29 +109,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -148,29 +154,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2), dims(3)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2), dims(3)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -191,29 +199,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2), dims(3), dims(4)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2), dims(3), dims(4)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -234,29 +244,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -277,29 +289,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -320,29 +334,31 @@ call hdf_shape_check(self, dname, dims, ier) +if (ier == 0) then select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6), dims(7)) - if (ier == 0) call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ier) value = buf end block type is (real(real32)) block real(real32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6), dims(7)) - if (ier == 0) call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ier) value = buf end block type is (integer(int32)) block integer(int32) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6), dims(7)) - if (ier == 0) call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) + call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ier) value = buf end block class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (present(ierr)) ierr = ier if (ier /= 0) then @@ -360,19 +376,21 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (character(*)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -391,17 +409,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -420,17 +440,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -449,17 +471,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -478,17 +502,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -507,17 +533,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -536,17 +564,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) @@ -565,17 +595,19 @@ call h%initialize(filename, ier, status='old') +if (ier == 0) then select type (value) type is (real(real64)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (real(real32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) type is (integer(int32)) - if (ier == 0) call h%read(dname, value, ier) + call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select +endif if (ier == 0) call h%finalize(ier) diff --git a/src/tests/test_array.f90 b/src/tests/test_array.f90 index 532c1468..dece4899 100644 --- a/src/tests/test_array.f90 +++ b/src/tests/test_array.f90 @@ -37,22 +37,22 @@ subroutine test_write_array(path) r2 = i2 !! write test data -call h5f%initialize(path//'/test.h5', ierr, status='old',action='rw',comp_lvl=1, chunk_size=[2,2,1,1,1,1,1]) -if(ierr/=0) error stop -call h5f%write('/int32-1d', i1, ierr) -if(ierr/=0) error stop -call h5f%write('/test/group2/int32-2d', i2, ierr) -if(ierr/=0) error stop -call h5f%write('/test/real2', r2, ierr) -if(ierr/=0) error stop -call h5f%write('/nan', nan, ierr) -if(ierr/=0) error stop +call h5f%initialize(path//'/test.h5', status='old',action='rw',comp_lvl=1, chunk_size=[2,2,1,1,1,1,1]) + +call h5f%write('/int32-1d', i1) +call h5f%write('/test/group2/int32-2d', i2) +call h5f%write('/test/real2', r2) +call h5f%write('/nan', nan) + !> test writing wrong size call h5f%write('/int32-1d', [-1], ierr) -if(ierr==0) error stop 'did not error for write array shape mismatch' +if(ierr==0) error stop 'test_write_array: did not error for write array shape mismatch' -call h5f%finalize(ierr) -if(ierr/=0) error stop +!> test writing wrong rank +call h5f%write('/int32-1d', i2, ierr) +if(ierr==0) error stop 'test_write_array: did not error for write array rank mismatch' + +call h5f%finalize() !! Read tests call h5f%initialize(path//'/test.h5', ierr,status='old',action='r') @@ -76,7 +76,7 @@ subroutine test_write_array(path) !> check that 1D disk into 2D raises error call h5f%read('/int32-1d', i2, ierr) -if (ierr==0) error stop 'failed to error on rank mismatch' +if (ierr==0) error stop 'failed to error on read rank mismatch' ! --- real