mirror of
https://github.com/HDFGroup/hdf5.git
synced 2026-09-25 04:09:44 +03:00
Scot Breitenfeld
109e670e73
h5close_f reset its count of the objects created by h5open_f with
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, &
H5OPEN_NUM_OBJ, error)
passing the H5F module variable H5OPEN_NUM_OBJ as the actual argument for
the INTENT(OUT) obj_count dummy, while h5fget_obj_count_f also reads
H5OPEN_NUM_OBJ by use association. F2018 15.5.2.13 prohibits referencing a
variable through use association once it has been redefined through a dummy
argument in the same call, so the result depended on how the compiler
implemented argument association. Where the actual argument was passed by
reference the subtraction collapsed to 0 - 0 and produced the intended zero;
where the compiler used copy-in/copy-out it evaluated 0 - H5OPEN_NUM_OBJ and
left the count negative.
A negative count then defeats the guard at the top of h5open_f, which returns
early when H5OPEN_NUM_OBJ is non-zero. h5open_f reported success without
calling h5init_types_c, leaving H5T_NATIVE_INTEGER and the other predefined
types holding identifiers that h5close_f had released.
h5close_f now assigns the count directly, which is what the comment there has
always described. h5fget_obj_count_f computes into a local variable so that no
caller can reintroduce the aliasing; note that this change alone would make
the old h5close_f call site produce the negative count on every compiler
rather than only on some, so the two belong together. H5OPEN_NUM_OBJ is also
given an initial value, since h5open_f tests it before anything assigns to it.
h5fget_obj_count_f subtracted every object created by h5open_f from a count of
a single object type, so with the interface open a query such as
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_FILE_F, n, error)
returned a negative n and hdferr of 0. h5open_f now records what it leaves open
per object type, and a count is adjusted by the recorded value for the types
being counted, so the adjustment does not depend on which types the
initialization creates. The check for a negative count runs both on the value
returned by H5Fget_obj_count and after the adjustment.
h5fget_obj_ids_f applied no such adjustment, so it returned the identifiers
h5open_f opened alongside the application's own and disagreed with
h5fget_obj_count_f about the same query: with only a file and a group open,
H5F_OBJ_ALL_F counted 2 objects but listed 62. The C API reports 2 and 2. An
application walking the list found datatypes it never opened, and closing them
breaks the Fortran interface. h5fget_obj_ids_f now excludes those identifiers,
requesting enough from H5Fget_obj_ids that max_objs of the application's own
can still be returned when the two are interleaved.
The h5open/h5close test verified its object counts by calling
h5fget_obj_count_f after h5close_f, when h5open_f is the only call the Fortran
interface permits. Those checks move to after the interface is reopened, where
they additionally confirm that the predefined types are valid again, that the
preceding h5close_f released the previous h5open_f's types, and that
h5fget_obj_ids_f agrees with h5fget_obj_count_f.
The Fortran tests also aborted unrecoverable failures with STOP, which exits
with a success status whether the stop code is absent or is a string, so a run
that died part way through reported no failure to CTest. They now exit through
h5_exit_f(1). The STOPs that end a run normally, in fflush1 and in the async
test's skip path for a build without MPI_THREAD_MULTIPLE, are unchanged.
Fixes #6642
Fixes #6648
Reported and diagnosed by Dom Heinzeller.
1152 lines
45 KiB
Fortran
1152 lines
45 KiB
Fortran
!****h* root/fortran/test/tH5T.f90
|
|
!
|
|
! NAME
|
|
! tH5T.f90
|
|
!
|
|
! FUNCTION
|
|
! Basic testing of Fortran H5T APIs.
|
|
!
|
|
! COPYRIGHT
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
! Copyright by The HDF Group. *
|
|
! All rights reserved. *
|
|
! *
|
|
! This file is part of HDF5. The full HDF5 copyright notice, including *
|
|
! terms governing use, modification, and redistribution, is contained in *
|
|
! the LICENSE file, which can be found at the root of the source code *
|
|
! distribution tree, or in https://www.hdfgroup.org/licenses. *
|
|
! If you do not have access to either file, you may request a copy from *
|
|
! help@hdfgroup.org. *
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
!
|
|
! CONTAINS SUBROUTINES
|
|
! compoundtest, basic_data_type_test, enumtest, test_derived_flt
|
|
!
|
|
!*****
|
|
|
|
MODULE TH5T
|
|
|
|
USE HDF5
|
|
USE TH5_MISC
|
|
USE TH5_MISC_GEN
|
|
|
|
CONTAINS
|
|
|
|
SUBROUTINE compoundtest(cleanup, total_error)
|
|
!
|
|
! This program creates a dataset that is one dimensional array of
|
|
! structures {
|
|
! character*2
|
|
! integer
|
|
! double precision
|
|
! real
|
|
! }
|
|
! Data is written and read back by fields.
|
|
!
|
|
! The following H5T interface functions are tested:
|
|
! h5tcopy_f, h5tset(get)_size_f, h5tcreate_f, h5tinsert_f, h5tclose_f,
|
|
! h5tget_class_f, h5tget_member_name_f, h5tget_member_offset_f, h5tget_member_type_f,
|
|
! h5tequal_f, h5tinsert_array_f, h5tcommit_f, h5tencode_f, h5tdecode_f
|
|
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
INTEGER, INTENT(OUT) :: total_error
|
|
|
|
CHARACTER(LEN=8), PARAMETER :: filename = "compound" ! File name
|
|
CHARACTER(LEN=80) :: fix_filename
|
|
CHARACTER(LEN=8), PARAMETER :: dsetname = "Compound" ! Dataset name
|
|
INTEGER, PARAMETER :: dimsize = 6 ! Size of the dataset
|
|
INTEGER, PARAMETER :: COMP_NUM_MEMBERS = 4 ! Number of members in the compound datatype
|
|
|
|
INTEGER(HID_T) :: file_id ! File identifier
|
|
INTEGER(HID_T) :: dset_id ! Dataset identifier
|
|
INTEGER(HID_T) :: dspace_id ! Dataspace identifier
|
|
INTEGER(HID_T) :: dtype_id ! Compound datatype identifier
|
|
INTEGER(HID_T) :: dtarray_id ! Compound datatype identifier
|
|
INTEGER(HID_T) :: arrayt_id ! Array datatype identifier
|
|
INTEGER(HID_T) :: dt1_id ! Memory datatype identifier (for character field)
|
|
INTEGER(HID_T) :: dt2_id ! Memory datatype identifier (for integer field)
|
|
INTEGER(HID_T) :: dt3_id ! Memory datatype identifier (for double precision field)
|
|
INTEGER(HID_T) :: dt4_id ! Memory datatype identifier (for real field)
|
|
INTEGER(HID_T) :: dt5_id ! Memory datatype identifier
|
|
INTEGER(HID_T) :: membtype_id ! Datatype identifier
|
|
INTEGER(HID_T) :: plist_id ! Dataset transfer property
|
|
|
|
|
|
INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/dimsize/) ! Dataset dimensions
|
|
INTEGER :: rank = 1 ! Dataset rank
|
|
|
|
INTEGER :: error ! Error flag
|
|
INTEGER(SIZE_T) :: type_size ! Size of the datatype
|
|
INTEGER(SIZE_T) :: type_sizec ! Size of the character datatype
|
|
INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
|
|
INTEGER(SIZE_T) :: type_sized ! Size of the double precision datatype
|
|
INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
|
|
INTEGER(SIZE_T) :: offset ! Member's offset
|
|
INTEGER(SIZE_T) :: offset_out ! Member's offset
|
|
CHARACTER(LEN=2), DIMENSION(dimsize) :: char_member
|
|
CHARACTER(LEN=2), DIMENSION(dimsize) :: char_member_out ! Buffer to read data out
|
|
INTEGER, DIMENSION(dimsize) :: int_member
|
|
INTEGER, DIMENSION(dimsize) :: int_member_out
|
|
REAL(KIND=Fortran_DOUBLE), DIMENSION(dimsize) :: double_member
|
|
REAL(KIND=Fortran_DOUBLE), DIMENSION(dimsize) :: double_member_out
|
|
REAL, DIMENSION(dimsize) :: real_member
|
|
REAL, DIMENSION(dimsize) :: real_member_out
|
|
INTEGER :: i
|
|
INTEGER :: class ! Datatype class
|
|
INTEGER :: num_members ! Number of members in the compound datatype
|
|
CHARACTER(LEN=256) :: member_name
|
|
INTEGER :: len ! Length of the name of the compound datatype member
|
|
INTEGER :: member_index ! index of the field
|
|
INTEGER(HSIZE_T), DIMENSION(3) :: array_dims=(/2,3,4/)
|
|
INTEGER :: array_dims_range = 3
|
|
INTEGER :: elements = 24 ! number of elements in the array_dims array.
|
|
INTEGER(SIZE_T) :: sizechar
|
|
INTEGER(HSIZE_T), DIMENSION(1) :: data_dims
|
|
LOGICAL :: flag = .TRUE.
|
|
|
|
CHARACTER(LEN=1024) :: cmpd_buf
|
|
INTEGER(SIZE_T) :: cmpd_buf_size=0
|
|
INTEGER(HID_T) :: decoded_tid1
|
|
INTEGER(HID_T) :: decoded_tid2
|
|
|
|
INTEGER(HID_T) :: fixed_str1, fixed_str2
|
|
LOGICAL :: are_equal
|
|
INTEGER(SIZE_T), PARAMETER :: str_size = 10
|
|
INTEGER(SIZE_T) :: query_size
|
|
|
|
! Test h5tcreate_f with H5T_STRING_F option:
|
|
! Create fixed-length string in two ways and make sure they are the same
|
|
|
|
CALL h5tcopy_f(H5T_FORTRAN_S1, fixed_str1, error)
|
|
CALL check("h5tcopy_f", error, total_error)
|
|
CALL h5tset_size_f(fixed_str1, str_size, error)
|
|
CALL check("h5tset_size_f", error, total_error)
|
|
CALL h5tset_strpad_f(fixed_str1, H5T_STR_NULLTERM_F, error)
|
|
CALL check("h5tset_strpad_f", error, total_error)
|
|
|
|
CALL h5tcreate_f(H5T_STRING_F, str_size, fixed_str2, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
CALL h5tset_strpad_f(fixed_str2, H5T_STR_NULLTERM_F, error)
|
|
CALL check("h5tset_strpad_f", error, total_error)
|
|
|
|
CALL h5tequal_f(fixed_str1, fixed_str2, are_equal, error)
|
|
IF(.NOT.are_equal)THEN
|
|
CALL check("h5tcreate_f", -1, total_error)
|
|
ENDIF
|
|
|
|
CALL h5tget_size_f(fixed_str1, query_size, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
|
|
IF(query_size.NE.str_size)THEN
|
|
CALL check("h5tget_size_f", -1, total_error)
|
|
ENDIF
|
|
|
|
CALL h5tget_size_f(fixed_str2, query_size, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
|
|
IF(query_size.NE.str_size)THEN
|
|
CALL check("h5tget_size_f", -1, total_error)
|
|
ENDIF
|
|
|
|
CALL h5tclose_f(fixed_str1,error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
CALL h5tclose_f(fixed_str2,error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
data_dims(1) = dimsize
|
|
!
|
|
! Initialize data buffer.
|
|
!
|
|
do i = 1, dimsize
|
|
char_member(i)(1:1) = char(65+i)
|
|
char_member(i)(2:2) = char(65+i)
|
|
char_member_out(i)(1:1) = char(65)
|
|
char_member_out(i)(2:2) = char(65)
|
|
int_member(i) = i
|
|
int_member_out(i) = 0
|
|
double_member(i) = 2.* i
|
|
double_member_out(i) = 0.
|
|
real_member(i) = 3. * i
|
|
real_member_out(i) = 0.
|
|
enddo
|
|
|
|
!
|
|
! Set dataset transfer property to preserve partially initialized fields
|
|
! during write/read to/from dataset with compound datatype.
|
|
!
|
|
CALL h5pcreate_f(H5P_DATASET_XFER_F, plist_id, error)
|
|
CALL check("h5pcreate_f", error, total_error)
|
|
CALL h5pset_preserve_f(plist_id, flag, error)
|
|
CALL check("h5pset_preserve_f", error, total_error)
|
|
!
|
|
! Create a new file using default properties.
|
|
!
|
|
CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error)
|
|
if (error .ne. 0) then
|
|
write(*,*) "Cannot modify filename"
|
|
CALL h5_exit_f(1)
|
|
endif
|
|
CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error)
|
|
CALL check("h5fcreate_f", error, total_error)
|
|
|
|
!
|
|
! Create the dataspace.
|
|
!
|
|
CALL h5screate_simple_f(rank, dims, dspace_id, error)
|
|
CALL check("h5screate_simple_f", error, total_error)
|
|
!
|
|
! Create compound datatype.
|
|
!
|
|
! First calculate total size by calculating sizes of each member
|
|
!
|
|
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, error)
|
|
CALL check("h5tcopy_f", error, total_error)
|
|
sizechar = 2
|
|
CALL h5tset_size_f(dt5_id, sizechar, error)
|
|
CALL check("h5tset_size_f", error, total_error)
|
|
CALL h5tget_size_f(dt5_id, type_sizec, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
CALL h5tget_size_f(H5T_NATIVE_INTEGER, type_sizei, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
CALL h5tget_size_f(H5T_NATIVE_DOUBLE, type_sized, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
CALL h5tget_size_f(H5T_NATIVE_REAL, type_sizer, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
!write(*,*) "get sizes", type_sizec, type_sizei, type_sizer, type_sized
|
|
type_size = type_sizec + type_sizei + type_sized + type_sizer
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
!
|
|
! Insert members
|
|
!
|
|
! CHARACTER*2 member
|
|
!
|
|
offset = 0
|
|
CALL h5tinsert_f(dtype_id, "char_field", offset, dt5_id, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! INTEGER member
|
|
!
|
|
offset = offset + type_sizec ! Offset of the second member is 2
|
|
CALL h5tinsert_f(dtype_id, "integer_field", offset, H5T_NATIVE_INTEGER, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! DOUBLE PRECISION member
|
|
!
|
|
offset = offset + type_sizei ! Offset of the third member is 6
|
|
CALL h5tinsert_f(dtype_id, "double_field", offset, H5T_NATIVE_DOUBLE, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! REAL member
|
|
!
|
|
offset = offset + type_sized ! Offset of the last member is 14
|
|
CALL h5tinsert_f(dtype_id, "real_field", offset, H5T_NATIVE_REAL, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Create the dataset with compound datatype.
|
|
!
|
|
CALL h5dcreate_f(file_id, dsetname, dtype_id, dspace_id, &
|
|
dset_id, error)
|
|
CALL check("h5dcreate_f", error, total_error)
|
|
!
|
|
! Create memory types. We have to create a compound datatype
|
|
! for each member we want to write.
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sizec, dt1_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt1_id, "char_field", offset, dt5_id, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sizei, dt2_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt2_id, "integer_field", offset, H5T_NATIVE_INTEGER, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sized, dt3_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt3_id, "double_field", offset, H5T_NATIVE_DOUBLE, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sizer, dt4_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt4_id, "real_field", offset, H5T_NATIVE_REAL, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Write data by fields in the datatype. Fields order is not important.
|
|
!
|
|
CALL h5dwrite_f(dset_id, dt4_id, real_member, data_dims, error, xfer_prp = plist_id)
|
|
CALL check("h5dwrite_f", error, total_error)
|
|
CALL h5dwrite_f(dset_id, dt1_id, char_member, data_dims, error, xfer_prp = plist_id)
|
|
CALL check("h5dwrite_f", error, total_error)
|
|
CALL h5dwrite_f(dset_id, dt3_id, double_member, data_dims, error, xfer_prp = plist_id)
|
|
CALL check("h5dwrite_f", error, total_error)
|
|
CALL h5dwrite_f(dset_id, dt2_id, int_member, data_dims, error, xfer_prp = plist_id)
|
|
CALL check("h5dwrite_f", error, total_error)
|
|
|
|
!
|
|
! End access to the dataset and release resources used by it.
|
|
!
|
|
CALL h5dclose_f(dset_id, error)
|
|
CALL check("h5dclose_f", error, total_error)
|
|
|
|
!
|
|
! Terminate access to the data space.
|
|
!
|
|
CALL h5sclose_f(dspace_id, error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
!
|
|
! Terminate access to the datatype
|
|
!
|
|
CALL h5tclose_f(dtype_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt1_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt2_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt3_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt4_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
!
|
|
! Create and store compound datatype with the character and
|
|
! array members.
|
|
!
|
|
type_size = type_sizec + elements*type_sizer ! Size of compound datatype
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dtarray_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dtarray_id, "char_field", offset, H5T_NATIVE_CHARACTER, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
offset = type_sizec
|
|
CALL h5tarray_create_f(H5T_NATIVE_REAL, array_dims_range, array_dims, arrayt_id, error)
|
|
CALL check("h5tarray_create_f", error, total_error)
|
|
CALL h5tinsert_f(dtarray_id,"array_field", offset, arrayt_id, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
CALL h5tcommit_f(file_id, "Compound_with_array_member", dtarray_id, error)
|
|
CALL check("h5tcommit_f", error, total_error)
|
|
CALL h5tclose_f(arrayt_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dtarray_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
!
|
|
! Close the file.
|
|
!
|
|
CALL h5fclose_f(file_id, error)
|
|
CALL check("h5fclose_f", error, total_error)
|
|
|
|
!
|
|
! Open the file.
|
|
!
|
|
CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error)
|
|
CALL check("h5fopen_f", error, total_error)
|
|
!
|
|
! Open the dataset.
|
|
!
|
|
CALL h5dopen_f(file_id, dsetname, dset_id, error)
|
|
CALL check("h5dopen_f", error, total_error)
|
|
!
|
|
! Get datatype of the open dataset.
|
|
! Check it class, number of members, and member's names.
|
|
!
|
|
CALL h5dget_type_f(dset_id, dtype_id, error)
|
|
CALL check("h5dget_type_f", error, total_error)
|
|
CALL h5tget_class_f(dtype_id, class, error)
|
|
CALL check("h5dget_class_f", error, total_error)
|
|
if (class .ne. H5T_COMPOUND_F) then
|
|
write(*,*) " Wrong class type returned"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_nmembers_f(dtype_id, num_members, error)
|
|
CALL check("h5dget_nmembers_f", error, total_error)
|
|
if (num_members .ne. COMP_NUM_MEMBERS ) then
|
|
write(*,*) " Wrong number of members returned"
|
|
total_error = total_error + 1
|
|
endif
|
|
!
|
|
! Go through the members and find out their names and offsets.
|
|
! Also see if name corresponds to the index
|
|
!
|
|
do i = 1, num_members
|
|
CALL h5tget_member_name_f(dtype_id, i-1, member_name, len, error)
|
|
CALL check("h5tget_member_name_f", error, total_error)
|
|
CALL h5tget_member_offset_f(dtype_id, i-1, offset_out, error)
|
|
CALL check("h5tget_member_offset_f", error, total_error)
|
|
CALL h5tget_member_index_f(dtype_id, member_name(1:len), member_index, error)
|
|
CALL check("h5tget_member_index_f", error, total_error)
|
|
if(member_index .ne. i-1) then
|
|
write(*,*) "Index returned is incorrect"
|
|
write(*,*) member_index, i-1
|
|
total_error = total_error + 1
|
|
endif
|
|
|
|
CHECK_NAME: SELECT CASE (member_name(1:len))
|
|
CASE("char_field")
|
|
if(offset_out .ne. 0) then
|
|
write(*,*) "Offset of the char member is incorrect"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error)
|
|
CALL check("h5tget_member_type_f", error, total_error)
|
|
CALL h5tequal_f(membtype_id, dt5_id, flag, error)
|
|
CALL check("h5tequal_f", error, total_error)
|
|
if(.not. flag) then
|
|
write(*,*) "Wrong member type returned for character member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_class_f(dtype_id, i-1, class, error)
|
|
CALL check("h5tget_member_class_f",error, total_error)
|
|
if (class .ne. H5T_STRING_F) then
|
|
write(*,*) "Wrong class returned for character member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CASE("integer_field")
|
|
if(offset_out .ne. type_sizec) then
|
|
write(*,*) "Offset of the integer member is incorrect"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error)
|
|
CALL check("h5tget_member_type_f", error, total_error)
|
|
CALL h5tequal_f(membtype_id, H5T_NATIVE_INTEGER, flag, error)
|
|
CALL check("h5tequal_f", error, total_error)
|
|
if(.not. flag) then
|
|
write(*,*) "Wrong member type returned for integer member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_class_f(dtype_id, i-1, class, error)
|
|
CALL check("h5tget_member_class_f",error, total_error)
|
|
if (class .ne. H5T_INTEGER_F) then
|
|
write(*,*) "Wrong class returned for INTEGER member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CASE("double_field")
|
|
if(offset_out .ne. (type_sizec+type_sizei)) then
|
|
write(*,*) "Offset of the double precision member is incorrect"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error)
|
|
CALL check("h5tget_member_type_f", error, total_error)
|
|
CALL h5tequal_f(membtype_id, H5T_NATIVE_DOUBLE, flag, error)
|
|
CALL check("h5tequal_f", error, total_error)
|
|
if(.not. flag) then
|
|
write(*,*) "Wrong member type returned for double precision member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_class_f(dtype_id, i-1, class, error)
|
|
CALL check("h5tget_member_class_f",error, total_error)
|
|
if (class .ne. H5T_FLOAT_F) then
|
|
write(*,*) "Wrong class returned for double precision member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CASE("real_field")
|
|
if(offset_out .ne. (type_sizec+type_sizei+type_sized)) then
|
|
write(*,*) "Offset of the real member is incorrect"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error)
|
|
CALL check("h5tget_member_type_f", error, total_error)
|
|
CALL h5tequal_f(membtype_id, H5T_NATIVE_REAL, flag, error)
|
|
CALL check("h5tequal_f", error, total_error)
|
|
if(.not. flag) then
|
|
write(*,*) "Wrong member type returned for real member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CALL h5tget_member_class_f(dtype_id, i-1, class, error)
|
|
CALL check("h5tget_member_class_f",error, total_error)
|
|
if (class .ne. H5T_FLOAT_F) then
|
|
write(*,*) "Wrong class returned for real member"
|
|
total_error = total_error + 1
|
|
endif
|
|
CASE DEFAULT
|
|
write(*,*) "Wrong member's name"
|
|
total_error = total_error + 1
|
|
|
|
END SELECT CHECK_NAME
|
|
|
|
enddo
|
|
!
|
|
! Create memory datatype to read character member of the compound datatype.
|
|
!
|
|
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt2_id, error)
|
|
CALL check("h5tcopy_f", error, total_error)
|
|
sizechar = 2
|
|
CALL h5tset_size_f(dt2_id, sizechar, error)
|
|
CALL check("h5tset_size_f", error, total_error)
|
|
CALL h5tget_size_f(dt2_id, type_size, error)
|
|
CALL check("h5tget_size_f", error, total_error)
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dt1_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt1_id, "char_field", offset, dt2_id, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Read part of the dataset
|
|
!
|
|
CALL h5dread_f(dset_id, dt1_id, char_member_out, data_dims, error, H5S_ALL_F, H5S_ALL_F, H5P_DEFAULT_F)
|
|
CALL check("h5dread_f", error, total_error)
|
|
do i = 1, dimsize
|
|
if (char_member_out(i) .ne. char_member(i)) then
|
|
write(*,*) " Wrong character data is read back "
|
|
total_error = total_error + 1
|
|
endif
|
|
enddo
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sizei, dt5_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt5_id, "integer_field", offset, H5T_NATIVE_INTEGER, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Read part of the dataset
|
|
!
|
|
CALL h5dread_f(dset_id, dt5_id, int_member_out, data_dims, error)
|
|
CALL check("h5dread_f", error, total_error)
|
|
do i = 1, dimsize
|
|
if (int_member_out(i) .ne. int_member(i)) then
|
|
write(*,*) " Wrong integer data is read back "
|
|
total_error = total_error + 1
|
|
endif
|
|
enddo
|
|
!
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sized, dt3_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt3_id, "double_field", offset, H5T_NATIVE_DOUBLE, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Read part of the dataset
|
|
!
|
|
CALL h5dread_f(dset_id, dt3_id, double_member_out, data_dims, error)
|
|
CALL check("h5dread_f", error, total_error)
|
|
DO i = 1, dimsize
|
|
CALL VERIFY("h5dread_f:Wrong double precision data is read back", double_member_out(i), double_member(i), total_error)
|
|
ENDDO
|
|
!
|
|
!
|
|
CALL h5tcreate_f(H5T_COMPOUND_F, type_sizer, dt4_id, error)
|
|
CALL check("h5tcreate_f", error, total_error)
|
|
offset = 0
|
|
CALL h5tinsert_f(dt4_id, "real_field", offset, H5T_NATIVE_REAL, error)
|
|
CALL check("h5tinsert_f", error, total_error)
|
|
!
|
|
! Read part of the dataset
|
|
!
|
|
CALL h5dread_f(dset_id, dt4_id, real_member_out, data_dims, error)
|
|
CALL check("h5dread_f", error, total_error)
|
|
DO i = 1, dimsize
|
|
CALL VERIFY("h5dread_f:Wrong double precision data is read back", real_member_out(i), real_member(i), total_error)
|
|
ENDDO
|
|
!
|
|
! *-----------------------------------------------------------------------
|
|
! * Test encoding and decoding compound datatypes
|
|
! *-----------------------------------------------------------------------
|
|
!
|
|
! Encode compound type in a buffer
|
|
! -- First find the buffer size
|
|
|
|
CALL H5Tencode_f(dtype_id, cmpd_buf, cmpd_buf_size, error)
|
|
CALL check("H5Tencode_f", error, total_error)
|
|
|
|
! Try decoding bogus buffer with and without optional buffer size
|
|
|
|
CALL H5Tdecode_f(cmpd_buf, decoded_tid1, error, cmpd_buf_size)
|
|
CALL verify("H5Tdecode_f", error, -1, total_error)
|
|
|
|
CALL H5Tdecode_f(cmpd_buf, decoded_tid1, error)
|
|
CALL verify("H5Tdecode_f", error, -1, total_error)
|
|
|
|
CALL H5Tencode_f(dtype_id, cmpd_buf, cmpd_buf_size, error)
|
|
CALL check("H5Tencode_f", error, total_error)
|
|
|
|
! Decode from the compound buffer and return an object handle
|
|
CALL H5Tdecode_f(cmpd_buf, decoded_tid1, error, cmpd_buf_size)
|
|
CALL check("H5Tdecode_f", error, total_error)
|
|
|
|
! Verify that the datatype was copied exactly
|
|
|
|
CALL H5Tequal_f(decoded_tid1, dtype_id, flag, error)
|
|
CALL check("H5Tequal_f", error, total_error)
|
|
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
|
|
|
|
! Decode from the compound buffer without the optional parameter
|
|
CALL H5Tdecode_f(cmpd_buf, decoded_tid2, error)
|
|
CALL check("H5Tdecode_f", error, total_error)
|
|
|
|
! Verify that the datatype was copied exactly
|
|
CALL H5Tequal_f(decoded_tid2, dtype_id, flag, error)
|
|
CALL check("H5Tequal_f", error, total_error)
|
|
|
|
!
|
|
! Close all open objects.
|
|
!
|
|
CALL h5dclose_f(dset_id, error)
|
|
CALL check("h5dclose_f", error, total_error)
|
|
CALL h5tclose_f(dt1_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt2_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt3_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt4_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dt5_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5fclose_f(file_id, error)
|
|
CALL check("h5fclose_f", error, total_error)
|
|
|
|
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
|
|
CALL check("h5_cleanup_f", error, total_error)
|
|
RETURN
|
|
END SUBROUTINE compoundtest
|
|
|
|
|
|
|
|
|
|
SUBROUTINE basic_data_type_test(total_error)
|
|
|
|
! This subroutine tests following functionalities:
|
|
! H5tget_precision_f, H5tset_precision_f, H5tget_offset_f
|
|
! H5tset_offset_f, H5tget_pad_f, H5tset_pad_f, H5tget_sign_f,
|
|
! H5tset_sign_f, H5tget_ebias_f,H5tset_ebias_f, H5tget_norm_f,
|
|
! H5tset_norm_f, H5tget_inpad_f, H5tset_inpad_f, H5tget_cset_f,
|
|
! H5tset_cset_f, H5tget_strpad_f, H5tset_strpad_f
|
|
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(OUT) :: total_error
|
|
|
|
INTEGER(HID_T) :: dtype1_id, dtype2_id, dtype3_id, dtype4_id, dtype5_id
|
|
! datatype identifiers
|
|
INTEGER(SIZE_T) :: precision ! Datatype precision
|
|
INTEGER(SIZE_T) :: setprecision ! Datatype precision
|
|
INTEGER(SIZE_T) :: offset ! Datatype offset
|
|
INTEGER(SIZE_T) :: setoffset ! Datatype offset
|
|
INTEGER :: lsbpad !padding type of the least significant bit
|
|
INTEGER :: msbpad !padding type of the most significant bit
|
|
INTEGER :: sign !sign type for an integer type
|
|
INTEGER(SIZE_T) :: ebias1 !Datatype exponent bias of a floating-point type
|
|
INTEGER(SIZE_T) :: ebias2 !Datatype exponent bias of a floating-point type
|
|
INTEGER(SIZE_T) :: setebias
|
|
INTEGER :: norm !mantissa normalization of a floating-point datatype
|
|
INTEGER :: inpad !padding type for unused bits in floating-point datatypes.
|
|
INTEGER :: cset !character set type of a string datatype
|
|
INTEGER :: strpad !string padding method for a string datatype
|
|
INTEGER :: error !error flag
|
|
|
|
|
|
!
|
|
! Create a datatype
|
|
!
|
|
CALL h5tcopy_f(H5T_STD_U16BE, dtype1_id, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
!
|
|
!datatype type_id should be modifiable after h5tcopy_f
|
|
!
|
|
setprecision = 12
|
|
CALL h5tset_precision_f(dtype1_id, setprecision, error)
|
|
CALL check("h5set_precision_f",error,total_error)
|
|
CALL h5tget_precision_f(dtype1_id,precision, error)
|
|
CALL check("h5get_precision_f",error,total_error)
|
|
if(precision .ne. 12) then
|
|
write (*,*) "got precision is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tcopy_f(H5T_STD_I32LE, dtype2_id, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
setprecision = 12
|
|
CALL h5tset_precision_f(dtype2_id, setprecision, error)
|
|
CALL check("h5set_precision_f",error,total_error)
|
|
|
|
setoffset = 2
|
|
CALL h5tset_offset_f(dtype1_id, setoffset, error)
|
|
CALL check("h5set_offset_f",error,total_error)
|
|
setoffset = 10
|
|
CALL h5tset_offset_f(dtype2_id, setoffset, error)
|
|
CALL check("h5set_offset_f",error,total_error)
|
|
CALL h5tget_offset_f(dtype2_id,offset, error)
|
|
CALL check("h5get_offset_f",error,total_error)
|
|
if(offset .ne. 10) then
|
|
write (*,*) "got offset is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_pad_f(dtype2_id,H5T_PAD_ONE_F, H5T_PAD_ONE_F, error)
|
|
CALL check("h5set_pad_f",error,total_error)
|
|
CALL h5tget_pad_f(dtype2_id,lsbpad,msbpad, error)
|
|
CALL check("h5get_pad_f",error,total_error)
|
|
if((lsbpad .ne. H5T_PAD_ONE_F) .and. (msbpad .ne. H5T_PAD_ONE_F)) then
|
|
write (*,*) "got pad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
! CALL h5tset_sign_f(dtype2_id,H5T_SGN_2_F, error)
|
|
! CALL check("h5set_sign_f",error,total_error)
|
|
! CALL h5tget_sign_f(dtype2_id,sign, error)
|
|
CALL h5tget_sign_f(H5T_NATIVE_INTEGER, sign, error)
|
|
CALL check("h5tget_sign_f",error,total_error)
|
|
if(sign .ne. H5T_SGN_2_F ) then
|
|
write (*,*) "got sign is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tcopy_f(H5T_IEEE_F64BE, dtype3_id, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
CALL h5tcopy_f(H5T_IEEE_F32LE, dtype4_id, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
|
|
setebias = 257
|
|
CALL h5tset_ebias_f(dtype3_id, setebias, error)
|
|
CALL check("h5tset_ebias_f",error,total_error)
|
|
setebias = 1
|
|
CALL h5tset_ebias_f(dtype4_id, setebias, error)
|
|
CALL check("h5tset_ebias_f",error,total_error)
|
|
CALL h5tget_ebias_f(dtype3_id, ebias1, error)
|
|
CALL check("h5tget_ebias_f",error,total_error)
|
|
if(ebias1 .ne. 257 ) then
|
|
write (*,*) "got ebias is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
CALL h5tget_ebias_f(dtype4_id, ebias2, error)
|
|
CALL check("h5tget_ebias_f",error,total_error)
|
|
if(ebias2 .ne. 1 ) then
|
|
write (*,*) "got ebias is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
!attention:
|
|
!It seems that I can't use H5T_NORM_IMPLIED_F to set the norm value
|
|
!because I got error for the get_norm function
|
|
! CALL h5tset_norm_f(dtype3_id,H5T_NORM_IMPLIED_F , error)
|
|
! CALL check("h5tset_norm_f",error,total_error)
|
|
! CALL h5tget_norm_f(dtype3_id, norm, error)
|
|
! CALL check("h5tget_norm_f",error,total_error)
|
|
! if(norm .ne. H5T_NORM_IMPLIED_F ) then
|
|
! write (*,*) "got norm is not correct"
|
|
! total_error = total_error + 1
|
|
! end if
|
|
CALL h5tset_norm_f(dtype3_id, H5T_NORM_MSBSET_F , error)
|
|
CALL check("h5tset_norm_f",error,total_error)
|
|
CALL h5tget_norm_f(dtype3_id, norm, error)
|
|
CALL check("h5tget_norm_f",error,total_error)
|
|
if(norm .ne. H5T_NORM_MSBSET_F ) then
|
|
write (*,*) "got norm is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_norm_f(dtype3_id, H5T_NORM_NONE_F , error)
|
|
CALL check("h5tset_norm_f",error,total_error)
|
|
CALL h5tget_norm_f(dtype3_id, norm, error)
|
|
CALL check("h5tget_norm_f",error,total_error)
|
|
if(norm .ne. H5T_NORM_NONE_F ) then
|
|
write (*,*) "got norm is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_inpad_f(dtype3_id, H5T_PAD_ZERO_F , error)
|
|
CALL check("h5tset_inpad_f",error,total_error)
|
|
CALL h5tget_inpad_f(dtype3_id, inpad , error)
|
|
CALL check("h5tget_inpad_f",error,total_error)
|
|
if(inpad .ne. H5T_PAD_ZERO_F ) then
|
|
write (*,*) "got inpad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_inpad_f(dtype3_id,H5T_PAD_ONE_F , error)
|
|
CALL check("h5tset_inpad_f",error,total_error)
|
|
CALL h5tget_inpad_f(dtype3_id, inpad , error)
|
|
CALL check("h5tget_inpad_f",error,total_error)
|
|
if(inpad .ne. H5T_PAD_ONE_F ) then
|
|
write (*,*) "got inpad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_inpad_f(dtype3_id,H5T_PAD_BACKGROUND_F , error)
|
|
CALL check("h5tset_inpad_f",error,total_error)
|
|
CALL h5tget_inpad_f(dtype3_id, inpad , error)
|
|
CALL check("h5tget_inpad_f",error,total_error)
|
|
if(inpad .ne. H5T_PAD_BACKGROUND_F ) then
|
|
write (*,*) "got inpad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
! we should not apply h5tset_cset_f to non_character data typemake
|
|
|
|
! CALL h5tset_cset_f(dtype4_id, H5T_CSET_ASCII_F, error)
|
|
! CALL check("h5tset_cset_f",error,total_error)
|
|
! CALL h5tget_cset_f(dtype4_id, cset, error)
|
|
! CALL check("h5tget_cset_f",error,total_error)
|
|
! if(cset .ne. H5T_CSET_ASCII_F ) then
|
|
! write (*,*) "got cset is not correct"
|
|
! total_error = total_error + 1
|
|
! end if
|
|
|
|
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dtype5_id, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
CALL h5tset_cset_f(dtype5_id, H5T_CSET_ASCII_F, error)
|
|
CALL check("h5tset_cset_f",error,total_error)
|
|
CALL h5tget_cset_f(dtype5_id, cset, error)
|
|
CALL check("h5tget_cset_f",error,total_error)
|
|
if(cset .ne. H5T_CSET_ASCII_F ) then
|
|
write (*,*) "got cset is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
CALL h5tset_strpad_f(dtype5_id, H5T_STR_NULLPAD_F, error)
|
|
CALL check("h5tset_strpad_f",error,total_error)
|
|
CALL h5tget_strpad_f(dtype5_id, strpad, error)
|
|
CALL check("h5tget_strpad_f",error,total_error)
|
|
if(strpad .ne. H5T_STR_NULLPAD_F ) then
|
|
write (*,*) "got strpad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tset_strpad_f(dtype5_id, H5T_STR_SPACEPAD_F, error)
|
|
CALL check("h5tset_strpad_f",error,total_error)
|
|
CALL h5tget_strpad_f(dtype5_id, strpad, error)
|
|
CALL check("h5tget_strpad_f",error,total_error)
|
|
if(strpad .ne. H5T_STR_SPACEPAD_F ) then
|
|
write (*,*) "got strpad is not correct"
|
|
total_error = total_error + 1
|
|
end if
|
|
|
|
CALL h5tclose_f(dtype1_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dtype2_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dtype3_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dtype4_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5tclose_f(dtype5_id, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
|
|
RETURN
|
|
END SUBROUTINE basic_data_type_test
|
|
|
|
SUBROUTINE enumtest(cleanup, total_error)
|
|
|
|
IMPLICIT NONE
|
|
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
INTEGER, INTENT(OUT) :: total_error
|
|
CHARACTER(LEN=4), PARAMETER :: filename="enum"
|
|
CHARACTER(LEN=80) :: fix_filename
|
|
CHARACTER(LEN=8), PARAMETER :: dsetname="enumdset"
|
|
CHARACTER(LEN=4) :: true ="TRUE"
|
|
CHARACTER(LEN=5) :: false="FALSE"
|
|
CHARACTER(LEN=5) :: mem_name
|
|
|
|
INTEGER(HID_T) :: file_id
|
|
INTEGER(HID_T) :: dset_id
|
|
INTEGER(HID_T) :: dspace_id
|
|
INTEGER(HID_T) :: dtype_id, dtype, native_type
|
|
INTEGER :: error
|
|
INTEGER :: value
|
|
INTEGER(HSIZE_T), DIMENSION(1) :: dsize
|
|
INTEGER(SIZE_T) :: buf_size
|
|
INTEGER, DIMENSION(2) :: data
|
|
INTEGER(HSIZE_T), DIMENSION(7) :: dims
|
|
INTEGER :: order1, order2
|
|
! INTEGER(SIZE_T) :: type_size1, type_size2
|
|
INTEGER :: class
|
|
|
|
dims(1) = 2
|
|
dsize(1) = 2
|
|
data(1) = 1
|
|
data(2) = 0
|
|
!
|
|
! Create a new file using default properties.
|
|
!
|
|
CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error)
|
|
IF (error .NE. 0) THEN
|
|
WRITE(*,*) "Cannot modify filename"
|
|
CALL h5_exit_f(1)
|
|
ENDIF
|
|
CALL h5fcreate_f(fix_filename,H5F_ACC_TRUNC_F,file_id,error)
|
|
CALL check("h5fcreate_f", error, total_error)
|
|
!
|
|
! Create enumeration datatype with two values
|
|
!
|
|
CALL h5tenum_create_f(H5T_NATIVE_INTEGER,dtype_id,error)
|
|
CALL check("h5tenum_create_f", error, total_error)
|
|
CALL h5tenum_insert_f(dtype_id,true,DATA(1),error)
|
|
CALL check("h5tenum_insert_f", error, total_error)
|
|
CALL h5tenum_insert_f(dtype_id,false,DATA(2),error)
|
|
CALL check("h5tenum_insert_f", error, total_error)
|
|
!
|
|
! Create write and close a dataset with enum datatype
|
|
!
|
|
CALL h5screate_simple_f(1,dsize,dspace_id,error)
|
|
CALL check("h5screate_simple_f", error, total_error)
|
|
CALL h5dcreate_f(file_id,dsetname,dtype_id,dspace_id,dset_id,error)
|
|
CALL check("h5dcreate_f", error, total_error)
|
|
CALL h5dwrite_f(dset_id,dtype_id,DATA,dims,error)
|
|
CALL check("h5dwrite_f", error, total_error)
|
|
|
|
CALL H5Dget_type_f(dset_id, dtype, error)
|
|
CALL check("H5Dget_type_f", error, total_error)
|
|
|
|
CALL H5Tget_native_type_f(dtype, H5T_DIR_ASCEND_F, native_type, error)
|
|
CALL check("H5Tget_native_type_f",error, total_error)
|
|
|
|
! Verify the datatype retrieved and converted
|
|
CALL H5Tget_order_f(native_type, order1, error)
|
|
CALL check("H5Tget_order_f",error, total_error)
|
|
CALL H5Tget_order_f(H5T_NATIVE_INTEGER, order2, error)
|
|
CALL check("H5Tget_order_f",error, total_error)
|
|
CALL verify("H5Tget_native_type_f",order1, order2, total_error)
|
|
|
|
! this test depends on whether -i8 was specified
|
|
|
|
!!$ CALL H5Tget_size_f(native_type, type_size1, error)
|
|
!!$ CALL check("H5Tget_size_f",error, total_error)
|
|
!!$ CALL H5Tget_size_f(H5T_STD_I32BE, type_size2, error)
|
|
!!$ CALL check("H5Tget_size_f",error, total_error)
|
|
!!$ CALL verify("H5Tget_native_type_f", INT(type_size1), INT(type_size2), total_error)
|
|
|
|
CALL H5Tget_class_f(native_type, class, error)
|
|
CALL check("H5Tget_class_f",error, total_error)
|
|
CALL verify("H5Tget_native_type_f", INT(class), INT(H5T_ENUM_F), total_error)
|
|
|
|
CALL h5dclose_f(dset_id,error)
|
|
CALL check("h5dclose_f", error, total_error)
|
|
CALL h5sclose_f(dspace_id,error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
!
|
|
! Get value of "TRUE"
|
|
!
|
|
CALL h5tenum_valueof_f(dtype_id, "TRUE", value, error)
|
|
CALL check("h5tenum_valueof_f", error, total_error)
|
|
IF (value .NE. 1) THEN
|
|
WRITE(*,*) " Value of TRUE is not 1, error"
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
!
|
|
! Get name of 0
|
|
!
|
|
value = 0
|
|
buf_size = 5
|
|
CALL h5tenum_nameof_f(dtype_id, value, buf_size, mem_name, error)
|
|
CALL check("h5tenum_nameof_f", error, total_error)
|
|
IF (mem_name .NE. "FALSE") THEN
|
|
WRITE(*,*) " Wrong name for 0 value"
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
|
|
CALL h5tclose_f(dtype_id,error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
CALL h5fclose_f(file_id,error)
|
|
CALL check("h5fclose_f", error, total_error)
|
|
|
|
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
|
|
CALL check("h5_cleanup_f", error, total_error)
|
|
|
|
RETURN
|
|
END SUBROUTINE enumtest
|
|
|
|
!-------------------------------------------------------------------------
|
|
! * Function: test_derived_flt
|
|
! *
|
|
! * Purpose: Tests user-defined and query functions of floating-point types.
|
|
! * test h5tget/set_fields_f.
|
|
! *
|
|
! * Return: Success: 0
|
|
! *
|
|
! * Failure: number of errors
|
|
! *-------------------------------------------------------------------------
|
|
!
|
|
|
|
SUBROUTINE test_derived_flt(cleanup, total_error)
|
|
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
INTEGER, INTENT(OUT) :: total_error
|
|
INTEGER(hid_t) :: file=-1, tid1=-1, tid2=-1
|
|
INTEGER(hid_t) :: dxpl_id=-1
|
|
INTEGER(size_t) :: spos, epos, esize, mpos, msize
|
|
|
|
CHARACTER(LEN=15), PARAMETER :: filename="h5t_derived_flt"
|
|
CHARACTER(LEN=80) :: fix_filename
|
|
|
|
INTEGER(SIZE_T) :: precision1, offset1, ebias1, size1
|
|
INTEGER(SIZE_T) :: precision2, offset2, ebias2, size2
|
|
|
|
INTEGER :: error
|
|
|
|
! Create File
|
|
CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error)
|
|
IF (error .NE. 0) THEN
|
|
WRITE(*,*) "Cannot modify filename"
|
|
CALL h5_exit_f(1)
|
|
ENDIF
|
|
|
|
CALL h5fcreate_f(fix_filename,H5F_ACC_TRUNC_F,file,error)
|
|
CALL check("h5fcreate_f", error, total_error)
|
|
|
|
CALL h5pcreate_f(H5P_DATASET_XFER_F, dxpl_id, error)
|
|
CALL check("h5pcreate_f", error, total_error)
|
|
|
|
CALL h5tcopy_f(H5T_IEEE_F64LE, tid1, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
|
|
CALL h5tcopy_f(H5T_IEEE_F32LE, tid2, error)
|
|
CALL check("h5tcopy_f",error,total_error)
|
|
|
|
!------------------------------------------------------------------------
|
|
! * 1st floating-point type
|
|
! * size=7 byte, precision=42 bits, offset=3 bits, mantissa size=31 bits,
|
|
! * mantissa position=3, exponent size=10 bits, exponent position=34,
|
|
! * exponent bias=511. It can be illustrated in little-endian order as
|
|
! *
|
|
! * 6 5 4 3 2 1 0
|
|
! * ???????? ???SEEEE EEEEEEMM MMMMMMMM MMMMMMMM MMMMMMMM MMMMM???
|
|
! *
|
|
! * To create a new floating-point type, the following properties must be
|
|
! * set in the order of
|
|
! * set fields -> set offset -> set precision -> set size.
|
|
! * All these properties must be set before the type can function. Other
|
|
! * properties can be set anytime. Derived type size cannot be expanded
|
|
! * bigger than original size but can be decreased. There should be no
|
|
! * holes among the significant bits. Exponent bias usually is set
|
|
! * 2^(n-1)-1, where n is the exponent size.
|
|
! *-----------------------------------------------------------------------
|
|
|
|
CALL H5Tset_fields_f(tid1, INT(44,size_t), INT(34,size_t), INT(10,size_t), &
|
|
INT(3,size_t), INT(31,size_t), error)
|
|
CALL check("H5Tset_fields_f",error,total_error)
|
|
|
|
CALL H5Tset_offset_f(tid1, INT(3,size_t), error)
|
|
CALL check("H5Tset_offset_f",error,total_error)
|
|
|
|
CALL H5Tset_precision_f(tid1, INT(42,size_t), error)
|
|
CALL check("H5Tset_precision_f",error,total_error)
|
|
|
|
CALL H5Tset_size_f(tid1, INT(7,size_t), error)
|
|
CALL check("H5Tset_size_f",error,total_error)
|
|
|
|
CALL H5Tset_ebias_f(tid1, INT(511,size_t), error)
|
|
CALL check("H5Tset_ebias_f",error,total_error)
|
|
|
|
CALL H5Tset_pad_f(tid1, H5T_PAD_ZERO_F, H5T_PAD_ZERO_F, error)
|
|
CALL check("H5Tset_pad_f",error,total_error)
|
|
|
|
CALL h5tcommit_f(file, "new float type 1", tid1, error)
|
|
CALL check("h5tcommit_f", error, total_error)
|
|
|
|
CALL h5tclose_f(tid1, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
CALL H5Topen_f(file, "new float type 1", tid1, error)
|
|
CALL check("H5Topen_f", error, total_error)
|
|
|
|
CALL H5Tget_fields_f(tid1, spos, epos, esize, mpos, msize, error)
|
|
CALL check("H5Tget_fields_f", error, total_error)
|
|
|
|
IF(spos.NE.44 .OR. epos.NE.34 .OR. esize.NE.10 .OR. mpos.NE.3 .OR. msize.NE.31)THEN
|
|
CALL verify("H5Tget_fields_f", -1, 0, total_error)
|
|
ENDIF
|
|
|
|
CALL H5Tget_precision_f(tid1, precision1, error)
|
|
CALL check("H5Tget_precision_f", error, total_error)
|
|
CALL verify("H5Tget_precision_f", INT(precision1), 42, total_error)
|
|
|
|
CALL H5Tget_offset_f(tid1, offset1, error)
|
|
CALL check("H5Tget_offset_f", error, total_error)
|
|
CALL verify("H5Tget_offset_f", INT(offset1), 3, total_error)
|
|
|
|
CALL H5Tget_size_f(tid1, size1, error)
|
|
CALL check("H5Tget_size_f", error, total_error)
|
|
CALL verify("H5Tget_size_f", INT(size1), 7, total_error)
|
|
|
|
CALL H5Tget_ebias_f(tid1, ebias1, error)
|
|
CALL check("H5Tget_ebias_f", error, total_error)
|
|
CALL verify("H5Tget_ebias_f", INT(ebias1), 511, total_error)
|
|
|
|
!--------------------------------------------------------------------------
|
|
! * 2nd floating-point type
|
|
! * size=3 byte, precision=24 bits, offset=0 bits, mantissa size=16 bits,
|
|
! * mantissa position=0, exponent size=7 bits, exponent position=16, exponent
|
|
! * bias=63. It can be illustrated in little-endian order as
|
|
! *
|
|
! * 2 1 0
|
|
! * SEEEEEEE MMMMMMMM MMMMMMMM
|
|
! *--------------------------------------------------------------------------
|
|
|
|
CALL H5Tset_fields_f(tid2, INT(23,size_t), INT(16,size_t), INT(7,size_t), &
|
|
INT(0,size_t), INT(16,size_t), error)
|
|
CALL check("H5Tset_fields_f",error,total_error)
|
|
|
|
CALL H5Tset_offset_f(tid2, INT(0,size_t), error)
|
|
CALL check("H5Tset_offset_f",error,total_error)
|
|
|
|
CALL H5Tset_precision_f(tid2, INT(24,size_t), error)
|
|
CALL check("H5Tset_precision_f",error,total_error)
|
|
|
|
CALL H5Tset_size_f(tid2, INT(3,size_t), error)
|
|
CALL check("H5Tset_size_f",error,total_error)
|
|
|
|
CALL H5Tset_ebias_f(tid2, INT(63,size_t), error)
|
|
CALL check("H5Tset_ebias_f",error,total_error)
|
|
|
|
CALL H5Tset_pad_f(tid2, H5T_PAD_ZERO_F, H5T_PAD_ZERO_F, error)
|
|
CALL check("H5Tset_pad_f",error,total_error)
|
|
|
|
CALL h5tcommit_f(file, "new float type 2", tid2, error)
|
|
CALL check("h5tcommit_f", error, total_error)
|
|
|
|
CALL h5tclose_f(tid2, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
CALL H5Topen_f(file, "new float type 2", tid2, error)
|
|
CALL check("H5Topen_f", error, total_error)
|
|
|
|
CALL H5Tget_fields_f(tid2, spos, epos, esize, mpos, msize, error)
|
|
CALL check("H5Tget_fields_f", error, total_error)
|
|
|
|
IF(spos.NE.23 .OR. epos.NE.16 .OR. esize.NE.7 .OR. mpos.NE.0 .OR. msize.NE.16)THEN
|
|
CALL verify("H5Tget_fields_f", -1, 0, total_error)
|
|
ENDIF
|
|
|
|
CALL H5Tget_precision_f(tid2, precision2, error)
|
|
CALL check("H5Tget_precision_f", error, total_error)
|
|
CALL verify("H5Tget_precision_f", INT(precision2), 24, total_error)
|
|
|
|
CALL H5Tget_offset_f(tid2, offset2, error)
|
|
CALL check("H5Tget_offset_f", error, total_error)
|
|
CALL verify("H5Tget_offset_f", INT(offset2), 0, total_error)
|
|
|
|
CALL H5Tget_size_f(tid2, size2, error)
|
|
CALL check("H5Tget_size_f", error, total_error)
|
|
CALL verify("H5Tget_size_f", INT(size2), 3, total_error)
|
|
|
|
CALL H5Tget_ebias_f(tid2, ebias2, error)
|
|
CALL check("H5Tget_ebias_f", error, total_error)
|
|
CALL verify("H5Tget_ebias_f", INT(ebias2), 63, total_error)
|
|
|
|
CALL h5tclose_f(tid1, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
CALL h5tclose_f(tid2, error)
|
|
CALL check("h5tclose_f", error, total_error)
|
|
|
|
CALL H5Pclose_f(dxpl_id, error)
|
|
CALL check("H5Pclose_f", error, total_error)
|
|
|
|
CALL h5fclose_f(file,error)
|
|
CALL check("h5fclose_f", error, total_error)
|
|
|
|
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
|
|
CALL check("h5_cleanup_f", error, total_error)
|
|
|
|
END SUBROUTINE test_derived_flt
|
|
|
|
END MODULE TH5T
|