diff --git a/README.md b/README.md index e56cca45..0f64697d 100644 --- a/README.md +++ b/README.md @@ -146,18 +146,16 @@ type(hdf5_file) :: h5f * string attributes may be applied to any variable at time of writing or later. * `chunk_size` and `comp_lvl` options must be set to **enable compression** -`integer, intent(out) :: ierr` is a mandatory parameter. It will be non-zero if error detected. +`integer, intent(out) :: ierr` is an optional parameter. It will be non-zero if error detected. This value should be checked, particularly for write operations to avoid missing error conditions. -The design choice to keep `error stop` out of h5fortran was in line with the HDF5 library itself. -Major Fortran libraries like MPI also make this design choice, perhaps since Fortran doesn't currently -have exception handling. +If `ierr` is omitted, then h5fortran will raise `error stop` if an error occurs. ### Create new HDF5 file, with variable "value1" ```fortran -call h5f%initialize('test.h5', ierr, status='new',action='w') +call h5f%initialize('test.h5', status='new',action='w') -call h5f%write('/value1', 123., ierr) +call h5f%write('/value1', 123.) call h5f%finalize(ierr) ``` @@ -168,9 +166,9 @@ call h5f%finalize(ierr) * if file `test.h5` does not exist, create it and add a variable to it. ```fortran -call h5f%initialize('test.h5', ierr, status='unknown',action='rw') +call h5f%initialize('test.h5', status='unknown',action='rw') -call h5f%write('/value1', 123., ierr) +call h5f%write('/value1', 123.) call h5f%finalize(ierr) ``` @@ -180,9 +178,9 @@ call h5f%finalize(ierr) ```fortran real :: val2(1000,1000,3) = 0. -call h5f%initialize('test.h5', ierr, comp_lvl=1) +call h5f%initialize('test.h5', comp_lvl=1) -call h5f%write('/value2', val2, ierr) +call h5f%write('/value2', val2) call h5f%finalize(ierr) ``` @@ -205,16 +203,16 @@ exists = h5f%exists("/foo") ### Read scalar, 3-D array of unknown size ```fortran -call h5f%initialize('test.h5', ierr, status='old',action='r') +call h5f%initialize('test.h5', status='old',action='r') integer(hsize_t), allocatable :: dims(:) real, allocatable :: A(:,:,:) -call h5f%shape('/foo',dims, ierr) +call h5f%shape('/foo',dims) allocate(A(dims(1), dims(2), dims(3))) call h5f%read('/foo', A) -call h5f%finalize(ierr) +call h5f%finalize() ``` ### is dataset contiguous or chunked? @@ -222,9 +220,9 @@ call h5f%finalize(ierr) Assumed file handle h5f was already initialized, the logical status is inspected: ```fortran -is_contig = h5f%is_contig('/foo', ierr) +is_contig = h5f%is_contig('/foo') -is_chunked = h5f%is_chunked('/foo', ierr) +is_chunked = h5f%is_chunked('/foo') ``` ### Create group "scope" @@ -232,11 +230,11 @@ is_chunked = h5f%is_chunked('/foo', ierr) ```fortran real :: val2(1000,1000,3) = 0. -call h5f%initialize('test.h5', ierr) +call h5f%initialize('test.h5') -call h5f%write('/scope/', ierr) +call h5f%write('/scope/') -call h5f%finalize(ierr) +call h5f%finalize() ``` ## Permissive syntax diff --git a/src/interface.f90 b/src/interface.f90 index a56e3c82..0eaf6f01 100644 --- a/src/interface.f90 +++ b/src/interface.f90 @@ -164,28 +164,18 @@ module subroutine lt7read(filename, dname, value, ierr) end subroutine lt7read -module subroutine hdf_setup_write(self, dname, dtype, dims, sid, did, ierr, chunk_size) -class(hdf5_file), intent(inout) :: self -character(*), intent(in) :: dname -integer(HID_T), intent(in) :: dtype -integer(HSIZE_T), intent(in) :: dims(:) -integer(HID_T), intent(out) :: sid, did -integer, intent(in), optional :: chunk_size(:) -integer, intent(out) :: ierr -end subroutine hdf_setup_write - module subroutine hdf_write_scalar(self,dname,value, ierr) class(hdf5_file), intent(inout) :: self character(*), intent(in) :: dname class(*), intent(in) :: value -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_scalar module subroutine hdf_write_1d(self,dname,value, ierr) class(hdf5_file), intent(inout) :: self character(*), intent(in) :: dname class(*), intent(in) :: value(:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_1d module subroutine hdf_write_2d(self,dname,value, ierr, chunk_size) @@ -193,7 +183,7 @@ module subroutine hdf_write_2d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_2d module subroutine hdf_write_3d(self,dname,value, ierr, chunk_size) @@ -201,7 +191,7 @@ module subroutine hdf_write_3d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_3d module subroutine hdf_write_4d(self,dname,value, ierr, chunk_size) @@ -209,7 +199,7 @@ module subroutine hdf_write_4d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:,:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_4d module subroutine hdf_write_5d(self,dname,value, ierr, chunk_size) @@ -217,7 +207,7 @@ module subroutine hdf_write_5d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:,:,:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_5d module subroutine hdf_write_6d(self,dname,value, ierr, chunk_size) @@ -225,7 +215,7 @@ module subroutine hdf_write_6d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:,:,:,:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_6d module subroutine hdf_write_7d(self,dname,value, ierr, chunk_size) @@ -233,7 +223,7 @@ module subroutine hdf_write_7d(self,dname,value, ierr, chunk_size) character(*), intent(in) :: dname class(*), intent(in) :: value(:,:,:,:,:,:,:) integer, intent(in), optional :: chunk_size(rank(value)) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_write_7d @@ -241,7 +231,7 @@ module subroutine hdf_get_shape(self, dname, dims, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname integer(HSIZE_T), intent(out), allocatable :: dims(:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_get_shape module integer function hdf_get_layout(self, dname) result(layout) @@ -270,74 +260,74 @@ module subroutine hdf_read_scalar(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(inout) :: value -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_scalar module subroutine hdf_read_1d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_1d module subroutine hdf_read_2d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_2d module subroutine hdf_read_3d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_3d module subroutine hdf_read_4d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:,:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_4d module subroutine hdf_read_5d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:,:,:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_5d module subroutine hdf_read_6d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:,:,:,:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_6d module subroutine hdf_read_7d(self, dname, value, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname class(*), intent(out) :: value(:,:,:,:,:,:,:) -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_read_7d module subroutine hdf_open_group(self, gname, ierr) class(hdf5_file), intent(inout) :: self character(*), intent(in) :: gname -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_open_group module subroutine hdf_close_group(self, ierr) class(hdf5_file), intent(inout) :: self -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine hdf_close_group module subroutine writeattr(self,dname,attr,attrval, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: dname, attr, attrval -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr end subroutine writeattr end interface @@ -350,7 +340,7 @@ subroutine hdf_initialize(self,filename,ierr, status,action,comp_lvl,chunk_size, class(hdf5_file), intent(inout) :: self character(*), intent(in) :: filename -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr character(*), intent(in), optional :: status character(*), intent(in), optional :: action integer, intent(in), optional :: comp_lvl @@ -359,6 +349,7 @@ subroutine hdf_initialize(self,filename,ierr, status,action,comp_lvl,chunk_size, character(:), allocatable :: lstatus, laction logical :: exists +integer :: ier self%filename = filename @@ -377,22 +368,43 @@ subroutine hdf_initialize(self,filename,ierr, status,action,comp_lvl,chunk_size, endif !> Initialize FORTRAN interface. -call h5open_f(ierr) -if (check(ierr, 'ERROR: HDF5 library initialize')) return +call h5open_f(ier) +if (check(ier, 'ERROR: HDF5 library initialize')) then + if (present(ierr)) then + ierr = ier + return + else + error stop + endif +endif !> get library version -call h5get_libversion_f(self%libversion(1), self%libversion(2), self%libversion(3), ierr) +call h5get_libversion_f(self%libversion(1), self%libversion(2), self%libversion(3), ier) ! if (self%verbose) print '(A,3I3)', 'HDF5 version: ',self%libversion -if (check(ierr, 'ERROR: HDF5 library get version')) return +if (check(ier, 'ERROR: HDF5 library get version')) then + if (present(ierr)) then + ierr = ier + return + else + error stop + endif +endif if(self%verbose) then - call h5eset_auto_f(1, ierr) + call h5eset_auto_f(1, ier) else - call h5eset_auto_f(0, ierr) + call h5eset_auto_f(0, ier) +endif +if (check(ier, 'ERROR: HDF5 library set traceback')) then + if (present(ierr)) then + ierr = ier + return + else + error stop + endif endif -if (check(ierr, 'ERROR: HDF5 library set traceback')) return -lstatus = 'old' +lstatus = 'unknown' if(present(status)) lstatus = toLower(status) laction = 'rw' @@ -402,48 +414,54 @@ subroutine hdf_initialize(self,filename,ierr, status,action,comp_lvl,chunk_size, case ('old', 'unknown') select case(laction) case('read','r') !< Open an existing file. - inquire(file=filename, exist=exists) - if (.not.exists) then - write(stderr,*) 'ERROR: ' // filename // ' does not exist.' - ierr = -1 - return - endif - call h5fopen_f(filename,H5F_ACC_RDONLY_F,self%lid,ierr) + call h5fopen_f(filename,H5F_ACC_RDONLY_F,self%lid,ier) case('write','readwrite','w','rw', 'r+', 'append', 'a') inquire(file=filename, exist=exists) - if(lstatus == 'unknown' .and. .not.exists) then - call h5fcreate_f(filename, H5F_ACC_TRUNC_F, self%lid, ierr) - if (check(ierr, 'ERROR: ' // filename // ' could not be created')) return + if(lstatus /= 'old' .and. .not.exists) then + call h5fcreate_f(filename, H5F_ACC_TRUNC_F, self%lid, ier) else - call h5fopen_f(filename, H5F_ACC_RDWR_F, self%lid, ierr) - if (check(ierr, 'ERROR: ' // filename // ' could not be opened in read/write')) return + call h5fopen_f(filename, H5F_ACC_RDWR_F, self%lid, ier) endif case default write(stderr,*) 'Unsupported action -> ' // laction - ierr = 128 + ier = 128 endselect case('new','replace') - call h5fcreate_f(filename, H5F_ACC_TRUNC_F, self%lid, ierr) - if (check(ierr, 'ERROR: ' // filename // ' could not be created')) return + call h5fcreate_f(filename, H5F_ACC_TRUNC_F, self%lid, ier) case default write(stderr,*) 'Unsupported status -> '// lstatus - ierr = 128 -endselect + ier = 128 +end select + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // filename // ' could not be created')) then + if (present(ierr)) return + error stop +endif end subroutine hdf_initialize subroutine hdf_finalize(self, ierr) class(hdf5_file), intent(inout) :: self -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr +integer :: ier !> close hdf5 file -call h5fclose_f(self%lid, ierr) -if (check(ierr, 'ERROR: HDF5 file close: ' // self%filename)) return +call h5fclose_f(self%lid, ier) +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: HDF5 file close: ' // self%filename)) then + if (present(ierr)) return + error stop +endif !> Close Fortran interface. -call h5close_f(ierr) -if (check(ierr, 'ERROR: HDF5 library close')) return +call h5close_f(ier) +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: HDF5 library close')) then + if (present(ierr)) return + error stop +endif !> sentinel lid self%lid = 0 @@ -456,9 +474,10 @@ subroutine hdf_write_group(self, gname, ierr) class(hdf5_file), intent(in) :: self character(*), intent(in) :: gname !< relative path to group -integer, intent(out) :: ierr +integer, intent(out), optional :: ierr integer(HID_T) :: gid +integer :: ier integer :: sp, ep, sl logical :: gexist @@ -475,15 +494,27 @@ subroutine hdf_write_group(self, gname, ierr) ! check subgroup exists sp = sp + ep - call h5lexists_f(self%lid, gname(1:sp-1), gexist, ierr) - if (check(ierr, 'ERROR: did not find group ' // gname // ' in ' // self%filename)) return + call h5lexists_f(self%lid, gname(1:sp-1), gexist, ier) + if (present(ierr)) ierr = ier + if (check(ier, 'ERROR: did not find group ' // gname // ' in ' // self%filename)) then + if (present(ierr)) return + error stop + endif if(.not.gexist) then - call h5gcreate_f(self%lid, gname(1:sp-1), gid, ierr) - if (check(ierr, 'ERROR: creating group ' // gname // ' in ' // self%filename)) return - - call h5gclose_f(gid, ierr) - if (check(ierr, 'ERROR: closing group ' // gname // ' in ' // self%filename)) return + call h5gcreate_f(self%lid, gname(1:sp-1), gid, ier) + if (present(ierr)) ierr = ier + if (check(ier, 'ERROR: creating group ' // gname // ' in ' // self%filename)) then + if (present(ierr)) return + error stop + endif + + call h5gclose_f(gid, ier) + if (present(ierr)) ierr = ier + if (check(ier, 'ERROR: closing group ' // gname // ' in ' // self%filename)) then + if (present(ierr)) return + error stop + endif endif end do @@ -506,38 +537,58 @@ 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) :: ierr +integer, intent(out), optional :: ierr integer(SIZE_T) :: dsize integer(HSIZE_T) :: ddims(size(dims)) -integer :: dtype, drank +integer :: dtype, drank, ier if (.not.self%exist(dname)) then write(stderr,*) 'ERROR: ' // dname // ' does not exist in ' // self%filename - ierr = -1 - return + if (present(ierr)) then + ierr = -1 + return + else + error stop + endif 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, ierr) -if (check(ierr, 'ERROR: get_dataset_ndim ' // dname // ' read ' // self%filename)) return +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 if (drank /= size(dims)) then write(stderr,'(A,I6,A,I6)') 'ERROR: rank mismatch ' // dname // ' = ',drank,' variable rank =', size(dims) - ierr = -1 - return + if (present(ierr)) then + ierr = -1 + return + else + error stop + endif endif !> check for matching size, else bad reads can occur. -call h5ltget_dataset_info_f(self%lid, dname, ddims, dtype, dsize, ierr) -if (check(ierr, 'ERROR: get_dataset_info ' // dname // ' read ' // self%filename)) return +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 if(.not. all(dims == ddims)) then write(stderr,*) 'ERROR: shape mismatch ' // dname // ' = ',ddims,' variable shape =', dims - ierr = -1 - return + if (present(ierr)) then + ierr = -1 + return + else + error stop endif +endif end subroutine hdf_shape_check diff --git a/src/read.f90 b/src/read.f90 index 32a7b43d..d78f5907 100644 --- a/src/read.f90 +++ b/src/read.f90 @@ -13,20 +13,27 @@ module procedure hdf_get_shape !! must get dims before info, as "dims" must be allocated or segfault occurs. integer(SIZE_T) :: dsize -integer :: dtype, drank +integer :: dtype, drank, ier + +ier = 0 if (.not.self%exist(dname)) then write(stderr, *) 'ERROR: ' // dname // ' does not exist in ' // self%filename - ierr = -1 - return + ier = -1 endif -call h5ltget_dataset_ndims_f(self%lid, dname, drank, ierr) -if (check(ierr, 'ERROR: '// dname // ' rank ' // self%filename)) return +if (ier == 0) call h5ltget_dataset_ndims_f(self%lid, dname, drank, ier) -allocate(dims(drank)) -call h5ltget_dataset_info_f(self%lid, dname, dims, dtype, dsize, ierr) -if (check(ierr, 'ERROR: ' // dname // ' info ' // self%filename)) return +if (ier == 0) then + allocate(dims(drank)) + call h5ltget_dataset_info_f(self%lid, dname, dims, dtype, dsize, ier) +endif + +if (present(ierr)) ierr = ier +if (ier /= 0) then + if (present(ierr)) return + error stop +endif end procedure hdf_get_shape @@ -40,7 +47,6 @@ if (.not.self%exist(dname)) then write(stderr, *) 'ERROR: ' // dname // ' does not exist in ' // self%filename - ierr = -1 return endif diff --git a/src/reader.f90 b/src/reader.f90 index 3fdb4459..e62e1f93 100644 --- a/src/reader.f90 +++ b/src/reader.f90 @@ -15,33 +15,40 @@ module procedure hdf_read_scalar integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + +ier = 0 if (.not.self%exist(dname)) then write(stderr,*) 'ERROR: ' // dname // ' does not exist in ' // self%filename - ierr = -1 - return + ier = -1 endif select type (value) type is (character(*)) block character(len(value)) :: buf - call h5ltread_dataset_string_f(self%lid, dname, buf, ierr) + if (ier == 0) call h5ltread_dataset_string_f(self%lid, dname, buf, ier) value = buf end block return type is (real(real64)) - call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ierr) + if (ier == 0) call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) type is (real(real32)) - call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ierr) + if (ier == 0) call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_REAL_KIND), value, dims, ier) type is (integer(int32)) - call h5ltread_dataset_f(self%lid, dname, h5kind_to_type(kind(value),H5_INTEGER_KIND), value, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_scalar @@ -49,36 +56,42 @@ module procedure hdf_read_1d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_1d @@ -86,36 +99,42 @@ module procedure hdf_read_2d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_2d @@ -123,36 +142,42 @@ module procedure hdf_read_3d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_3d @@ -160,36 +185,42 @@ module procedure hdf_read_4d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_4d @@ -197,36 +228,42 @@ module procedure hdf_read_5d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_5d @@ -234,36 +271,42 @@ module procedure hdf_read_6d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) select type (value) type is (real(real64)) block real(real64) :: buf(dims(1), dims(2), dims(3), dims(4), dims(5), dims(6)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_6d @@ -271,36 +314,42 @@ module procedure hdf_read_7d integer(HSIZE_T) :: dims(rank(value)) +integer :: ier + dims = shape(value) -call hdf_shape_check(self, dname, dims, ierr) -if (ierr /= 0) return +call hdf_shape_check(self, dname, dims, ier) 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)) - call h5ltread_dataset_double_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_float_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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)) - call h5ltread_dataset_int_f(self%lid, dname, buf, dims, ierr) + if (ier == 0) 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.' - ierr = -1 + ier = -1 end select -if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename +if (present(ierr)) ierr = ier +if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' read ' // self%filename + if (present(ierr)) return + error stop +endif end procedure hdf_read_7d @@ -310,27 +359,28 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (character(*)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt0read @@ -340,25 +390,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt1read @@ -368,25 +419,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt2read @@ -396,25 +448,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt3read @@ -424,25 +477,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt4read @@ -452,25 +506,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt5read @@ -480,25 +535,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt6read @@ -508,25 +564,26 @@ integer :: ier call h%initialize(filename, ier, status='old') -if (check(ier, 'ERROR: open ' // dname // ' read_lt ' // filename)) return select type (value) type is (real(real64)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (real(real32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) type is (integer(int32)) - call h%read(dname, value, ier) + if (ier == 0) call h%read(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' read_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' read_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt7read diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index 2a36ef26..ad7715d4 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -27,7 +27,7 @@ endif() add_executable(testh5 -test_hdf5_ifc.f90 test_lt.f90 test_array.f90 test_scalar.f90) +test_hdf5_ifc.f90 test_lt.f90 test_array.f90 test_scalar.f90 test_string.f90) target_link_libraries(testh5 PRIVATE h5fortran::h5fortran) if(${CMAKE_Fortran_COMPILER_ID} STREQUAL GNU) target_compile_options(testh5 PRIVATE -Wno-compare-reals) diff --git a/src/tests/meson.build b/src/tests/meson.build index 23b173d7..01b9f953 100644 --- a/src/tests/meson.build +++ b/src/tests/meson.build @@ -26,7 +26,7 @@ test('deflate', test_deflate, timeout: 10) testh5 = executable('test_hdf5', - sources: ['test_hdf5_ifc.f90', 'test_lt.f90', 'test_array.f90', 'test_scalar.f90'], + sources: ['test_hdf5_ifc.f90', 'test_lt.f90', 'test_array.f90', 'test_scalar.f90', 'test_string.f90'], dependencies: hdf5_interface, fortran_args: quiet) test('h5interface', testh5, diff --git a/src/tests/test_error.f90 b/src/tests/test_error.f90 index 7f5b3483..2d8a6b73 100644 --- a/src/tests/test_error.f90 +++ b/src/tests/test_error.f90 @@ -89,6 +89,8 @@ subroutine test_wrong_type(path) integer :: u,ierr character(:), allocatable :: filename +print *, 'test_wrong_type: begin test' + filename = path // '/junk.h5' call h5f%initialize(filename, ierr, status='replace', action='write', verbose=.false.) if(ierr/=0) error stop 'test_wrong_type: creating file' diff --git a/src/tests/test_hdf5_ifc.f90 b/src/tests/test_hdf5_ifc.f90 index d25f8c9c..8479f94b 100644 --- a/src/tests/test_hdf5_ifc.f90 +++ b/src/tests/test_hdf5_ifc.f90 @@ -1,11 +1,13 @@ !! unit tests and registration tests of HDF5 OO interface use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan use, intrinsic:: iso_fortran_env, only: int32, real32, real64, stderr=>error_unit -use, intrinsic:: iso_c_binding, only: c_null_char -use h5fortran, only: hdf5_file, toLower, strip_trailing_null, truncate_string_null, h5write, h5read + +use h5fortran, only: hdf5_file, h5write, h5read + use test_lt, only : test_readwrite_lt use test_array, only : test_write_array, test_readwrite_array use test_scalar, only : test_scalar_rw +use test_string, only : test_string_rw, test_lowercase, test_strip_null implicit none @@ -13,7 +15,7 @@ character(:), allocatable :: path character(256) :: argv -integer :: i,l,ierr +integer :: i,l call get_command_argument(1, argv, length=l, status=i) if (i /= 0 .or. l == 0) then @@ -56,97 +58,49 @@ contains -subroutine test_lowercase() - -character(*), parameter :: hello = 'HeLl0 Th3rE !>? ' - !! Fortran 2003 allocatable string - -if (.not.(toLower(hello)=='hell0 th3re !>? ')) error stop 'error: lowercase conversion' - -if (.not.(trim(toLower(hello))=='hell0 th3re !>?')) error stop 'Allocatable lowercase conversion error' +subroutine testGroup(path) -if(.not.all(toLower(['Hi','hI'])==['hi','hi'])) error stop 'error on array conversion' +type(hdf5_file) :: h5f +character(*), intent(in) :: path -end subroutine test_lowercase +integer :: ierr +call h5f%initialize(path//'/test_groups.h5', status='new',action='rw') -subroutine test_strip_null() +call h5f%write('/test/') -character(*), parameter :: hello = 'HeLl0 Th3rE !>? ' +call h5f%open('/test') -if (.not.strip_trailing_null(hello // c_null_char) == hello) error stop 'problem stripping trailing null' +call h5f%write('group3/scalar', 1_int32) -end subroutine test_strip_null +call h5f%write('group3/scalar_real', 1._real32) +call h5f%close() -subroutine testGroup(path) -type(hdf5_file) :: h5f -character(*), intent(in) :: path - -call h5f%initialize(path//'/test_groups.h5', ierr, status='new',action='rw') -call h5f%write('/test/', ierr) -if (ierr /= 0) error stop -call h5f%open('/test', ierr) -if (ierr /= 0) error stop -call h5f%write('group3/scalar', 1_int32, ierr) -if (ierr /= 0) error stop -call h5f%write('group3/scalar_real', 1._real32, ierr) -if (ierr /= 0) error stop -call h5f%close(ierr) -if (ierr /= 0) error stop -call h5f%finalize(ierr) -if (ierr /= 0) error stop +call h5f%finalize() end subroutine testGroup subroutine test_write_attributes(path) + type(hdf5_file) :: h5f character(*), intent(in) :: path -call h5f%initialize(path//'/test.h5', ierr) -if (ierr /= 0) error stop -call h5f%writeattr('/nan','note','this is just a little number', ierr) -if (ierr /= 0) error stop -call h5f%finalize(ierr) -if (ierr /= 0) error stop - -end subroutine test_write_attributes - +integer :: ierr -subroutine test_string_rw(path) -type(hdf5_file) :: h5f -character(*), intent(in) :: path -character(2) :: value -character(1024) :: val1k -character(:), allocatable :: final +call h5f%initialize(path//'/test_attr.h5') -call h5f%initialize(path//'/test_string.h5', ierr, status='new', action='rw') -if (ierr /= 0) error stop -call h5f%write('/little', '42', ierr) -if (ierr /= 0) error stop -call h5f%read('/little', value, ierr) -if (ierr /= 0) error stop -if (value /= '42') then - write(stderr,*) 'string dataset read/write verification failure. Value: '// value - error stop -endif +call h5f%write('/x', 1) -!! try reading too much data, then truncating to first C_NULL -call h5f%read('/little', val1k, ierr) +call h5f%writeattr('/x','note','this is just a little number', ierr) if (ierr /= 0) error stop -final = truncate_string_null(val1k) -if (len(final) /= 2) then - write(stderr, *) 'trimming str to c_null did not work, got len() = ', len(final) - write(stderr, *) iachar(final(3:3)) - error stop -endif +call h5f%writeattr('/x', 'foo', 'hi') -call h5f%finalize(ierr) -if (ierr /= 0) error stop +call h5f%finalize() -end subroutine test_string_rw +end subroutine test_write_attributes subroutine test_writeExistingVariable(path) @@ -157,23 +111,17 @@ subroutine test_writeExistingVariable(path) fn = path//'/overwrite.h5' -call h5f%initialize(fn, ierr, status='new',action='w') -if (ierr /= 0) error stop -call h5f%write('/scalar_int', 42_int32, ierr) -if (ierr /= 0) error stop -call h5f%write('/int1d', [42_int32, 1_int32], ierr) -if (ierr /= 0) error stop -call h5f%finalize(ierr) -if (ierr /= 0) error stop +call h5f%initialize(fn, status='new',action='w') -call h5f%initialize(fn, ierr, status='old',action='rw') -if (ierr /= 0) error stop -call h5f%write('/scalar_int', 100_int32, ierr) -if (ierr /= 0) error stop -call h5f%write('/int1d', [100_int32, 10_int32], ierr) -if (ierr /= 0) error stop -call h5f%finalize(ierr) -if (ierr /= 0) error stop +call h5f%write('/scalar_int', 42_int32) +call h5f%write('/int1d', [42_int32, 1_int32]) + +call h5f%finalize() + +call h5f%initialize(fn, status='old',action='rw') +call h5f%write('/scalar_int', 100_int32) +call h5f%write('/int1d', [100_int32, 10_int32]) +call h5f%finalize() end subroutine test_writeExistingVariable diff --git a/src/tests/test_string.f90 b/src/tests/test_string.f90 new file mode 100644 index 00000000..a1fb023f --- /dev/null +++ b/src/tests/test_string.f90 @@ -0,0 +1,71 @@ +module test_string + +use, intrinsic:: iso_fortran_env, only: stderr=>error_unit +use, intrinsic:: iso_c_binding, only: c_null_char + +use h5fortran, only : toLower, hdf5_file, strip_trailing_null, truncate_string_null + +implicit none + +contains + +subroutine test_lowercase() + +character(*), parameter :: hello = 'HeLl0 Th3rE !>? ' + !! Fortran 2003 allocatable string + +if (.not.(toLower(hello)=='hell0 th3re !>? ')) error stop 'error: lowercase conversion' + +if (.not.(trim(toLower(hello))=='hell0 th3re !>?')) error stop 'Allocatable lowercase conversion error' + +if(.not.all(toLower(['Hi','hI'])==['hi','hi'])) error stop 'error on array conversion' + +end subroutine test_lowercase + + +subroutine test_strip_null() + +character(*), parameter :: hello = 'HeLl0 Th3rE !>? ' + +if (.not.strip_trailing_null(hello // c_null_char) == hello) error stop 'problem stripping trailing null' + +end subroutine test_strip_null + + +subroutine test_string_rw(path) + +type(hdf5_file) :: h5f + +character(*), intent(in) :: path +character(2) :: value +character(1024) :: val1k +character(:), allocatable :: final + +integer :: ierr + +call h5f%initialize(path//'/test_string.h5', ierr, status='new', action='rw') +if (ierr /= 0) error stop + +call h5f%write('/little', '42') +call h5f%read('/little', value) + +if (value /= '42') then + write(stderr,*) 'string dataset read/write verification failure. Value: '// value + error stop +endif + +!! try reading too much data, then truncating to first C_NULL +call h5f%read('/little', val1k) +final = truncate_string_null(val1k) + +if (len(final) /= 2) then + write(stderr, *) 'trimming str to c_null did not work, got len() = ', len(final) + write(stderr, *) iachar(final(3:3)) + error stop +endif + +call h5f%finalize() + +end subroutine test_string_rw + +end module test_string \ No newline at end of file diff --git a/src/write.f90 b/src/write.f90 index 8351930f..f7a61daa 100644 --- a/src/write.f90 +++ b/src/write.f90 @@ -13,27 +13,36 @@ module procedure writeattr -logical :: exists +integer :: ier -call self%write(dname, ierr) -if (check(ierr, 'ERROR: create ' // dname // ' ' // self%filename)) return +!call self%write(dname, ier) -call h5ltpath_valid_f(self%lid, dname, .true., exists, ierr) -if (check(ierr, 'ERROR: checking existence: ' // dname // ' file ' // self%filename)) return +! if (ier == 0) call h5ltpath_valid_f(self%lid, dname, .true., exists, ier) -if (.not.exists) then - write(stderr,*) 'ERROR: variable ' // dname // ' must be created before writing ' // attr - return -endif +! if (.not.exists) then +! write(stderr,*) 'ERROR: variable ' // dname // ' must be created before writing ' // attr +! ier = -1 +! endif -call h5ltset_attribute_string_f(self%lid, dname, attr, attrval, ierr) -if (ierr /= 0) write(stderr,*) 'ERROR: writing attribute ' // attr // ' to ' // dname // ' file ' // self%filename +call h5ltset_attribute_string_f(self%lid, dname, attr, attrval, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' writeattr ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure writeattr -module procedure hdf_setup_write -!! hdf_setup_write(self, dname, dtype, dims, sid, did, ierr, chunk_size) +subroutine hdf_setup_write(self, dname, dtype, dims, sid, did, ierr, chunk_size) +class(hdf5_file), intent(inout) :: self +character(*), intent(in) :: dname +integer(HID_T), intent(in) :: dtype +integer(HSIZE_T), intent(in) :: dims(:) +integer(HID_T), intent(out) :: sid, did +integer, intent(in), optional :: chunk_size(:) +integer, intent(out) :: ierr logical :: exists integer(HID_T) :: pid @@ -53,7 +62,7 @@ if (check(ierr, 'ERROR: setup_write: open ' // dname // ' ' // self%filename)) return return else - call self%write(dname, ierr) + call self%hdf_write_group(dname, ierr) if (check(ierr, 'ERROR: setup_write: create ' // dname // ' ' // self%filename)) return endif @@ -76,7 +85,7 @@ endif if (check(ierr, 'ERROR: setup_write: dataset ' // dname // ' create ' // self%filename)) return -end procedure hdf_setup_write +end subroutine hdf_setup_write subroutine hdf_set_deflate(self, dims, pid, ierr, chunk_size) @@ -140,8 +149,14 @@ end subroutine hdf_wrapup module procedure hdf_open_group -call h5gopen_f(self%lid, gname, self%gid, ierr) -if (check(ierr, 'ERROR: opening group ' // gname // ' in ' // self%filename)) return +integer :: ier +call h5gopen_f(self%lid, gname, self%gid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: opening group ' // gname // ' in ' // self%filename)) then + if (present(ierr)) return + error stop +endif self%glid = self%lid self%lid = self%gid @@ -151,8 +166,15 @@ end subroutine hdf_wrapup module procedure hdf_close_group -call h5gclose_f(self%gid, ierr) -if (check(ierr, 'ERROR: closing group '//self%filename)) return +integer :: ier + +call h5gclose_f(self%gid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: closing group '//self%filename)) then + if (present(ierr)) return + error stop +endif self%lid = self%glid diff --git a/src/writer.f90 b/src/writer.f90 index fbad1bc3..541eae15 100644 --- a/src/writer.f90 +++ b/src/writer.f90 @@ -10,35 +10,47 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T), allocatable :: dims(:) +integer :: ier + allocate(dims(0)) select type (value) type is (character(*)) - call h5ltmake_dataset_string_f(self%lid, dname, value, ierr) - if (ierr /= 0) write(stderr,*) 'ERROR: ' // dname // ' write ' // self%filename + call h5ltmake_dataset_string_f(self%lid, dname, value, ier) + if (ier /= 0) then + write(stderr,*) 'ERROR: ' // dname // ' write ' // self%filename + if (present(ierr)) then + ierr = ier + return + else + error stop + endif + endif return type is (real(real64)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_scalar @@ -47,33 +59,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_1d @@ -82,33 +97,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_2d @@ -117,33 +135,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_3d @@ -152,33 +173,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_4d @@ -187,33 +211,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_5d @@ -222,33 +249,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_6d @@ -257,33 +287,36 @@ integer(HID_T) :: dtype, sid, did integer(HSIZE_T) :: dims(rank(value)) +integer :: ier select type (value) type is (real(real64)) dims = shape(value) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (real(real32)) dtype = h5kind_to_type(kind(value),H5_REAL_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) type is (integer(int32)) dtype = h5kind_to_type(kind(value),H5_INTEGER_KIND) dims = shape(value) - call hdf_setup_write(self,dname,dtype,dims,sid,did, ierr, chunk_size) - if (ierr /= 0) return - call h5dwrite_f(did, dtype, value, dims, ierr) + call hdf_setup_write(self,dname,dtype,dims,sid,did, ier, chunk_size) + if (ier == 0) call h5dwrite_f(did, dtype, value, dims, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' - ierr = -1 + ier = -1 end select -call hdf_wrapup(did, sid, ierr) -if (check(ierr, 'ERROR: ' // dname // ' write ' // self%filename)) return +if(ier == 0) call hdf_wrapup(did, sid, ier) + +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write ' // self%filename)) then + if (present(ierr)) return + error stop +endif end procedure hdf_write_7d @@ -293,28 +326,29 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (character(*)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt0write @@ -324,26 +358,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) - + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt1write @@ -353,26 +387,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) - + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt2write @@ -382,26 +416,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) - + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt3write @@ -411,25 +445,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt4write @@ -439,25 +474,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt5write @@ -467,26 +503,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) - + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt6write @@ -496,25 +532,26 @@ integer :: ier call h%initialize(filename, ier, status='unknown') -if (check(ier, 'ERROR: open ' // dname // ' write_lt ' // filename)) return select type (value) type is (real(real64)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (real(real32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) type is (integer(int32)) - call h%write(dname, value, ier) + if (ier == 0) call h%write(dname, value, ier) class default write(stderr,*) 'ERROR: ' // dname // ' datatype is not handled yet by h5fortran.' ier = -1 end select -if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) return -call h%finalize(ier) -if (check(ier, 'ERROR: close ' // dname // ' write_lt ' // filename)) return +if (ier == 0) call h%finalize(ier) -if(present(ierr)) ierr = ier +if (present(ierr)) ierr = ier +if (check(ier, 'ERROR: ' // dname // ' write_lt ' // filename)) then + if (present(ierr)) return + error stop +endif end procedure lt7write