mirrors/hdf5
2
0
Fork 0
mirror of https://github.com/HDFGroup/hdf5.git synced 2026-09-25 04:09:44 +03:00
Code Issues Packages Projects Releases Wiki Activity
Files
109e670e73791d8d087104ece7af1e75fd6ae61a
hdf5/fortran/test/tH5F.F90
T
Scot Breitenfeld 109e670e73 Fix h5open_f failing to re-initialize the Fortran interface (#6642) (#6649) 
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.
2026-09-01 15:12:55 -05:00

1628 lines
51 KiB
Fortran
Raw Blame History

!***rh* root/fortran/test/tH5F.f90
!
! NAME
! tH5F.f90
!
! FUNCTION
! Basic testing of Fortran H5F 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
! mountingtest, reopentest, get_name_test, plisttest,
! file_close, file_space, h5openclose, test_get_file_image
!
!*****
!
! In the mountingtest subroutine we create one file with a group in it,
! and another file with a dataset. Mounting is used to
! access the dataset from the second file as a member of a group
! in the first file.
! *****************************************
! *** H 5 F T E S T S
! *****************************************
MODULE TH5F
USE HDF5
USE TH5_MISC
USE TH5_MISC_GEN
USE ISO_C_BINDING
CONTAINS
! Verify that h5open_f re-initialized the Fortran interface. Enter with the
! interface closed; returns with it closed again.
SUBROUTINE check_reopen(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
INTEGER :: error
INTEGER(SIZE_T) :: obj_count ! open object count
INTEGER, DIMENSION(1:5) :: obj_type ! open object type to check
INTEGER(SIZE_T), PARAMETER :: max_ids = 20
INTEGER(HID_T), DIMENSION(1:max_ids) :: obj_ids
INTEGER(SIZE_T) :: num_objs
LOGICAL :: valid
INTEGER :: i
CALL h5open_f(error)
CALL check("h5open_f",error,total_error)
! A skipped re-initialization leaves the predefined types holding the
! identifiers h5close_f released, and h5open_f still reports success.
CALL h5iis_valid_f(H5T_NATIVE_INTEGER, valid, error)
CALL check("h5iis_valid_f",error,total_error)
IF(.NOT.valid)THEN
total_error = total_error + 1
ENDIF
obj_type(1) = H5F_OBJ_ALL_F
obj_type(2) = H5F_OBJ_FILE_F
obj_type(3) = H5F_OBJ_GROUP_F
obj_type(4) = H5F_OBJ_DATASET_F
obj_type(5) = H5F_OBJ_DATATYPE_F
! Only the types belonging to this h5open_f are open, so the ones from the
! preceding h5open_f were released by h5close_f.
DO i = 1, 5
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), obj_type(i), obj_count, error)
CALL check("h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.0)THEN
total_error = total_error + 1
ENDIF
! The identifiers h5open_f opened are not the application's either, so the
! list must agree with the count.
CALL h5fget_obj_ids_f(INT(H5F_OBJ_ALL_F,HID_T), obj_type(i), max_ids, obj_ids, error, num_objs)
CALL check("h5fget_obj_ids_f",error,total_error)
IF(num_objs.NE.obj_count)THEN
total_error = total_error + 1
ENDIF
ENDDO
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
END SUBROUTINE check_reopen
! Check that the object counts and the identifier lists agree with each other,
! and that both report only what the application has open.
SUBROUTINE objcount_ids(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=8), PARAMETER :: filename = "objcount"
CHARACTER(LEN=80) :: fix_filename
INTEGER(HID_T) :: fid, gid, did, sid, tid
INTEGER(HID_T), DIMENSION(1:20) :: obj_ids
INTEGER(SIZE_T) :: obj_count, obj_count2, num_objs
INTEGER :: error, i
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, fid, error)
CALL check("h5fcreate_f",error,total_error)
CALL h5gcreate_f(fid, "group", gid, error)
CALL check("h5gcreate_f",error,total_error)
CALL h5screate_f(H5S_SCALAR_F, sid, error)
CALL check("h5screate_f",error,total_error)
CALL h5dcreate_f(fid, "dset", H5T_NATIVE_INTEGER, sid, did, error)
CALL check("h5dcreate_f",error,total_error)
! One file, one group and one dataset are open. The datatypes h5open_f opened
! are not the application's and must not appear in either answer.
CALL count_and_list(H5F_OBJ_FILE_F, 1_SIZE_T, total_error)
CALL count_and_list(H5F_OBJ_GROUP_F, 1_SIZE_T, total_error)
CALL count_and_list(H5F_OBJ_DATASET_F, 1_SIZE_T, total_error)
CALL count_and_list(H5F_OBJ_DATATYPE_F, 0_SIZE_T, total_error)
CALL count_and_list(H5F_OBJ_ALL_F, 3_SIZE_T, total_error)
! Several types combined with IOR must count as the sum of the parts.
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), &
IOR(H5F_OBJ_GROUP_F,H5F_OBJ_DATASET_F), obj_count, error)
CALL check("h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.2)THEN
total_error = total_error + 1
WRITE(*,*) "IOR of two object types did not count as the sum of the parts"
ENDIF
! A combination that includes the types h5open_f opened is still adjusted.
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), &
IOR(H5F_OBJ_GROUP_F,H5F_OBJ_DATATYPE_F), obj_count2, error)
CALL check("h5fget_obj_count_f",error,total_error)
IF(obj_count2.NE.1)THEN
total_error = total_error + 1
WRITE(*,*) "IOR including datatypes did not exclude the h5open_f objects"
ENDIF
! max_objs smaller than the number of open objects must return exactly that
! many, and all of them the application's.
obj_ids = -1
CALL h5fget_obj_ids_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, 2_SIZE_T, obj_ids, error, num_objs)
CALL check("h5fget_obj_ids_f",error,total_error)
IF(num_objs.NE.2)THEN
total_error = total_error + 1
WRITE(*,*) "h5fget_obj_ids_f did not fill max_objs identifiers"
ENDIF
DO i = 1, 2
IF(obj_ids(i).NE.fid .AND. obj_ids(i).NE.gid .AND. obj_ids(i).NE.did)THEN
total_error = total_error + 1
WRITE(*,*) "h5fget_obj_ids_f returned an identifier the application did not open"
ENDIF
ENDDO
CALL h5dclose_f(did, error)
CALL check("h5dclose_f",error,total_error)
CALL h5sclose_f(sid, error)
CALL check("h5sclose_f",error,total_error)
CALL h5gclose_f(gid, error)
CALL check("h5gclose_f",error,total_error)
CALL h5fclose_f(fid, error)
CALL check("h5fclose_f",error,total_error)
! Nothing of the application's is left, and h5open_f's objects are still hidden.
CALL count_and_list(H5F_OBJ_ALL_F, 0_SIZE_T, total_error)
! An application's own datatype is reported even though h5open_f's are not. Here
! h5open_f's come first in the list, so a short buffer still has to be filled
! with the application's rather than exhausted on the ones being skipped.
CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error)
CALL check("h5tcopy_f",error,total_error)
CALL count_and_list(H5F_OBJ_DATATYPE_F, 1_SIZE_T, total_error)
obj_ids = -1
CALL h5fget_obj_ids_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_DATATYPE_F, 1_SIZE_T, obj_ids, error, num_objs)
CALL check("h5fget_obj_ids_f",error,total_error)
IF(num_objs.NE.1 .OR. obj_ids(1).NE.tid)THEN
total_error = total_error + 1
WRITE(*,*) "h5fget_obj_ids_f did not return the application's datatype"
ENDIF
CALL h5tclose_f(tid, error)
CALL check("h5tclose_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 objcount_ids
! Check that a count of obj_type is expected and that the identifier list
! reports the same number.
SUBROUTINE count_and_list(obj_type, expected, total_error)
IMPLICIT NONE
INTEGER, INTENT(IN) :: obj_type
INTEGER(SIZE_T), INTENT(IN) :: expected
INTEGER, INTENT(INOUT) :: total_error
INTEGER(HID_T), DIMENSION(1:20) :: obj_ids
INTEGER(SIZE_T) :: obj_count, num_objs
INTEGER :: error
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), obj_type, obj_count, error)
CALL check("h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.expected)THEN
total_error = total_error + 1
WRITE(*,*) "h5fget_obj_count_f reported ", obj_count, " instead of ", expected
ENDIF
CALL h5fget_obj_ids_f(INT(H5F_OBJ_ALL_F,HID_T), obj_type, 20_SIZE_T, obj_ids, error, num_objs)
CALL check("h5fget_obj_ids_f",error,total_error)
IF(num_objs.NE.obj_count)THEN
total_error = total_error + 1
WRITE(*,*) "h5fget_obj_ids_f reported ", num_objs, " but the count was ", obj_count
ENDIF
RETURN
END SUBROUTINE count_and_list
SUBROUTINE h5openclose(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
!
! flag to check operation success
!
INTEGER :: error
INTEGER :: j
! h5open_f is the only call allowed once h5close_f has closed the Fortran
! interface, so every check below is made from check_reopen.
DO j = 1, 2
CALL h5open_f(error)
CALL check("h5open_f",error,total_error)
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
CALL check_reopen(total_error)
ENDDO
! Test calling h5open_f multiple times without calling h5close_f
DO j = 1, 4
CALL h5open_f(error)
CALL check("h5open_f",error,total_error)
ENDDO
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
CALL check_reopen(total_error)
! Test calling h5open_f multiple times with a h5close_f in the series of h5open_f
DO j = 1, 5
CALL h5open_f(error)
CALL check("h5open_f",error,total_error)
IF(j.EQ.3)THEN
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
CALL check_reopen(total_error)
ENDIF
ENDDO
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
CALL check_reopen(total_error)
! Check calling h5close_f after already calling h5close_f
CALL h5close_f(error)
CALL check("h5close_f",error,total_error)
CALL check_reopen(total_error)
RETURN
END SUBROUTINE h5openclose
SUBROUTINE mountingtest(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
!
! the respective filenames are "mount1.h5" and "mount2.h5"
!
CHARACTER(LEN=6) :: filename1
CHARACTER(LEN=6) :: filename2
CHARACTER(LEN=80) :: fix_filename1
CHARACTER(LEN=80) :: fix_filename2
!
! data space rank and dimensions
!
INTEGER, PARAMETER :: RANK = 2
INTEGER, PARAMETER :: NX = 4
INTEGER, PARAMETER :: NY = 5
!
! File identifiers
!
INTEGER(HID_T) :: file1_id, file2_id
!
! Group identifier
!
INTEGER(HID_T) :: gid
!
! dataset identifier
!
INTEGER(HID_T) :: dset_id
!
! data space identifier
!
INTEGER(HID_T) :: dataspace
!
! data type identifier
!
INTEGER(HID_T) :: dtype_id
!
!The dimensions for the dataset.
!
INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/NX,NY/)
!
!return value for testing whether a file is in hdf5 format
!
LOGICAL :: status
!
!flag to check operation success
!
INTEGER :: error
INTEGER :: fintent
!
!general purpose integer
!
INTEGER :: i, j
!number of objects
INTEGER(SIZE_T) :: obj_count
INTEGER(HID_T) :: t1, t2, t3, t4
! File numbers
INTEGER :: file_num1
INTEGER :: file_num2
!
!data buffers
!
INTEGER, DIMENSION(NX,NY) :: data_in, data_out
INTEGER(HSIZE_T), DIMENSION(2) :: data_dims
filename1 = "mount1"
filename2 = "mount2"
do i = 1,80
fix_filename1(i:i) = " "
fix_filename2(i:i) = " "
enddo
!
!Initialize data_in buffer
!
do j = 1, NY
do i = 1, NX
data_in(i,j) = (i-1) + (j-1)
end do
end do
!
! Fix names of the files
!
CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error)
if(error .ne. 0) stop
CALL h5_fixname_f(filename2, fix_filename2, H5P_DEFAULT_F, error)
if(error .ne. 0) stop
! Test object counts
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, t1, error)
CALL check(" h5tcopy_f",error,total_error)
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, t2, error)
CALL check(" h5tcopy_f",error,total_error)
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, t3, error)
CALL check(" h5tcopy_f",error,total_error)
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, t4, error)
CALL check(" h5tcopy_f",error,total_error)
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.4)THEN
total_error = total_error + 1
ENDIF
!
!Create first file "mount1.h5" using default properties.
!
CALL h5fcreate_f(fix_filename1, H5F_ACC_TRUNC_F, file1_id, error)
CALL check("h5fcreate_f",error,total_error)
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.5)THEN
total_error = total_error + 1
ENDIF
CALL h5tclose_f(t1, error)
CALL check("h5tclose_f",error,total_error)
CALL h5tclose_f(t2, error)
CALL check("h5tclose_f",error,total_error)
CALL h5tclose_f(t3, error)
CALL check("h5tclose_f",error,total_error)
CALL h5tclose_f(t4, error)
CALL check("h5tclose_f",error,total_error)
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.1)THEN
total_error = total_error + 1
ENDIF
!
!Create group "/G" inside file "mount1.h5".
!
CALL h5gcreate_f(file1_id, "/G", gid, error)
CALL check("h5gcreate_f",error,total_error)
!
!close file and group identifiers.
!
CALL h5gclose_f(gid, error)
CALL check("h5gclose_f",error,total_error)
CALL h5fclose_f(file1_id, error)
CALL check("h5fclose_f",error,total_error)
!
!Create second file "mount2.h5" using default properties.
!
CALL h5fcreate_f(fix_filename2, H5F_ACC_TRUNC_F, file2_id, error)
CALL check("h5fcreate_f",error,total_error)
!
!Create data space for the dataset.
!
CALL h5screate_simple_f(RANK, dims, dataspace, error)
CALL check("h5screate_simple_f",error,total_error)
!
!Create dataset "/D" inside file "mount2.h5".
!
CALL h5dcreate_f(file2_id, "/D", H5T_NATIVE_INTEGER, dataspace, &
dset_id, error)
CALL check("h5dcreate_f",error,total_error)
!
! Write data_in to the dataset
!
data_dims(1) = NX
data_dims(2) = NY
CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data_in, data_dims, error)
CALL check("h5dwrite_f",error,total_error)
!
!close file, dataset and dataspace identifiers.
!
CALL h5sclose_f(dataspace, error)
CALL check("h5sclose_f",error,total_error)
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f",error,total_error)
CALL h5fclose_f(file2_id, error)
CALL check("h5fclose_f",error,total_error)
!
!test whether files are accessible as HDF5 (new, VOL-safe, way)
!
CALL h5fis_accessible_f(fix_filename1, status, error)
CALL check("h5fis_accessible_f",error,total_error)
IF ( .NOT. status ) THEN
write(*,*) "File ", fix_filename1, " is not accessible as hdf5"
CALL h5_exit_f(1)
END IF
CALL h5fis_accessible_f(fix_filename2, status, error)
CALL check("h5fis_accessible_f",error,total_error)
IF ( .NOT. status ) THEN
write(*,*) "File ", fix_filename2, " is not accessible as hdf5"
CALL h5_exit_f(1)
END IF
!
!test whether files are in hdf5 format (old way)
!
CALL h5fis_hdf5_f(fix_filename1, status, error)
CALL check("h5fis_hdf5_f",error,total_error)
IF ( .NOT. status ) THEN
write(*,*) "File ", fix_filename1, " is not in hdf5 format"
CALL h5_exit_f(1)
END IF
CALL h5fis_hdf5_f(fix_filename2, status, error)
CALL check("h5fis_hdf5_f",error,total_error)
IF ( .NOT. status ) THEN
write(*,*) "File ", fix_filename2, " is not in hdf5 format"
CALL h5_exit_f(1)
END IF
!
!reopen both files.
!
CALL h5fopen_f (fix_filename1, H5F_ACC_RDWR_F, file1_id, error)
CALL check("hfopen_f",error,total_error)
CALL h5fget_intent_f(file1_id, fintent, error)
CALL check("h5fget_intent_f",error,total_error)
IF(fintent.NE.H5F_ACC_RDWR_F)THEN
total_error = total_error + 1
ENDIF
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.1)THEN
total_error = total_error + 1
ENDIF
CALL h5fopen_f (fix_filename2, H5F_ACC_RDWR_F, file2_id, error)
CALL check("h5fopen_f",error,total_error)
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.2)THEN
total_error = total_error + 1
ENDIF
!
!Check file numbers
!
CALL h5fget_fileno_f(file1_id, file_num1, error)
CALL check("h5fget_fileno_f",error,total_error)
CALL h5fget_fileno_f(file2_id, file_num2, error)
CALL check("h5fget_fileno_f",error,total_error)
IF(file_num1 .EQ. file_num2) THEN
write(*,*) "file numbers aren't supposed to match"
END IF
!
!mount the second file under the first file's "/G" group.
!
CALL h5fmount_f (file1_id, "/G", file2_id, error)
CALL check("h5fmount_f",error,total_error)
!
!Access dataset D in the first file under /G/D name.
!
CALL h5dopen_f(file1_id, "/G/D", dset_id, error)
CALL check("h5dopen_f",error,total_error)
!
!Get dataset's data type.
!
CALL h5dget_type_f(dset_id, dtype_id, error)
CALL check("h5dget_type_f",error,total_error)
!
!Read the dataset.
!
CALL h5dread_f(dset_id, dtype_id, data_out, data_dims, error)
CALL check("h5dread_f",error,total_error)
!
!Compare the data.
!
do i = 1, NX
do j = 1, NY
IF (data_out(i,j) .NE. data_in(i, j)) THEN
total_error = total_error + 1
END IF
end do
end do
!
!Close dset_id and dtype_id.
!
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f",error,total_error)
CALL h5tclose_f(dtype_id, error)
CALL check("h5tclose_f",error,total_error)
!
!unmount the second file.
!
CALL h5funmount_f(file1_id, "/G", error);
CALL check("h5funmount_f",error,total_error)
!
!Close both files.
!
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.2)THEN
total_error = total_error + 1
ENDIF
CALL h5fclose_f(file1_id, error)
CALL check("h5fclose_f",error,total_error)
CALL h5fclose_f(file2_id, error)
CALL check("h5fclose_f",error,total_error)
CALL h5fget_obj_count_f(INT(H5F_OBJ_ALL_F,HID_T), H5F_OBJ_ALL_F, obj_count, error)
CALL check(" h5fget_obj_count_f",error,total_error)
IF(obj_count.NE.0)THEN
total_error = total_error + 1
ENDIF
IF(cleanup) CALL h5_cleanup_f(filename1, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f(filename2, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
RETURN
END SUBROUTINE mountingtest
!
! The following subroutine tests h5freopen_f.
! It creates the file which has name "reopen.h5" and
! the "/dset" dataset inside the file.
! writes the data to the file, close the dataset.
! Reopen the file based upon the file_id, open the
! dataset use the reopen_id then reads the
! dataset back to memory to test whether the data
! read is identical to the data written
!
SUBROUTINE reopentest(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
!
CHARACTER(LEN=6), PARAMETER :: filename = "reopen"
CHARACTER(LEN=80) :: fix_filename
INTEGER(HID_T) :: file_id, reopen_id ! File identifiers
INTEGER(HID_T) :: dset_id ! Dataset identifier
!
!dataset name is "dset"
!
CHARACTER(LEN=4), PARAMETER :: dsetname = "dset"
!
!data space rank and dimensions
!
INTEGER, PARAMETER :: RANK = 2
INTEGER, PARAMETER :: NX = 4
INTEGER, PARAMETER :: NY = 6
!
! data space identifier
!
INTEGER(HID_T) :: dataspace
!
!The dimensions for the dataset.
!
INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/NX,NY/)
!
!flag to check operation success
!
INTEGER :: error
!
!general purpose integer
!
INTEGER :: i, j
!
!array to store data
!
INTEGER, DIMENSION(4,6) :: dset_data, data_out
INTEGER(HSIZE_T), DIMENSION(2) :: data_dims
INTEGER(HSIZE_T) :: file_size
INTEGER :: file_num1
INTEGER :: file_num2
CHARACTER(LEN=80) :: file_name
INTEGER(SIZE_T) :: name_size
!
!initialize the dset_data array which will be written to the "/dset"
!
do j = 1, NY
do i = 1, NX
dset_data(i,j) = (i-1)*6 + j;
end do
end do
!
!Create file "reopen.h5" 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 data space for the dataset.
!
CALL h5screate_simple_f(RANK, dims, dataspace, error)
CALL check("h5screate_simple_f",error,total_error)
!
!Create dataset "/dset" inside the file .
!
CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dataspace, &
dset_id, error)
CALL check("h5dcreate_f",error,total_error)
!
!Write the dataset.
!
data_dims(1) = NX
data_dims(2) = NY
CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error)
CALL check("h5dwrite_f",error,total_error)
!
!close the dataset.
!
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f",error,total_error)
!
!close the dataspace.
!
CALL h5sclose_f(dataspace, error)
CALL check("h5sclose_f",error,total_error)
!
!Reopen file dsetf.h5.
!
CALL h5freopen_f(file_id, reopen_id, error)
CALL check("h5freopen_f",error,total_error)
!
!Check file size
!
CALL h5fget_filesize_f(file_id, file_size, error)
CALL check("h5fget_filesize_f",error,total_error)
!
!Check file numbers
!
CALL h5fget_fileno_f(file_id, file_num1, error)
CALL check("h5fget_fileno_f",error,total_error)
CALL h5fget_fileno_f(reopen_id, file_num2, error)
CALL check("h5fget_fileno_f",error,total_error)
IF(file_num1 .NE. file_num2) THEN
write(*,*) "file numbers don't match"
END IF
!
!Open the dataset based on the reopen_id.
!
CALL h5dopen_f(reopen_id, dsetname, dset_id, error)
CALL check("h5dopen_f",error,total_error)
!
!Get file name from the dataset identifier
!
CALL h5fget_name_f(dset_id, file_name, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(file_name(1:name_size) .NE. fix_filename(1:name_size)) THEN
write(*,*) "file name obtained from the dataset id is incorrect"
END IF
!
!Read the dataset.
!
CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error)
CALL check("h5dread_f",error,total_error)
!
!Compare the data.
!
do i = 1, NX
do j = 1, NY
IF (data_out(i,j) .NE. dset_data(i, j)) THEN
write(*, *) "reopen test error occurred"
END IF
end do
end do
!
!Close the dataset.
!
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f",error,total_error)
!
!Close the file identifiers.
!
CALL h5fclose_f(file_id, error)
CALL check("h5fclose_f",error,total_error)
CALL h5fclose_f(reopen_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 reopentest
! The following subroutine checks that h5fget_name_f produces
! correct output for a given obj_id and filename.
!
SUBROUTINE check_get_name(obj_id, fix_filename, len_filename, total_error)
IMPLICIT NONE
INTEGER(HID_T) :: obj_id ! Object identifier
CHARACTER(LEN=80), INTENT(IN) :: fix_filename ! Expected filename
INTEGER, INTENT(IN) :: len_filename ! The length of the filename
INTEGER, INTENT(INOUT) :: total_error ! Error count
CHARACTER(LEN=80):: file_name ! Filename buffer
INTEGER:: error ! HDF5 error code
INTEGER(SIZE_T):: name_size ! Filename length
INTEGER, PARAMETER :: sm_len = 2
CHARACTER(LEN=len_filename) :: filename_exact
CHARACTER(LEN=len_filename-sm_len) :: filename_sm
!
!Get file name from the dataset identifier
!
! Use an uninitialized buffer
CALL h5fget_name_f(obj_id, file_name, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(name_size .NE. LEN_TRIM(fix_filename))THEN
WRITE(*,*) " file name size obtained from the object id is incorrect"
total_error = total_error + 1
ENDIF
IF(file_name(1:name_size) .NE. TRIM(fix_filename)) THEN
WRITE(*,*) " file name obtained from the object id is incorrect"
total_error = total_error + 1
END IF
! Use a buffer initialized with spaces
file_name(:) = " "
CALL h5fget_name_f(obj_id, file_name, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(name_size .NE. LEN_TRIM(fix_filename))THEN
WRITE(*,*) " file name size obtained from the object id is incorrect"
total_error = total_error + 1
ENDIF
IF(file_name(1:name_size) .NE. TRIM(fix_filename)) THEN
WRITE(*,*) " file name obtained from the object id is incorrect"
total_error = total_error + 1
END IF
! Use a buffer initialized with non-whitespace characters
file_name(:) = "a"
CALL h5fget_name_f(obj_id, file_name, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(name_size .NE. LEN_TRIM(fix_filename))THEN
WRITE(*,*) " file name size obtained from the object id is incorrect"
total_error = total_error + 1
ENDIF
IF(file_name(1:name_size) .NE. TRIM(fix_filename)) THEN
WRITE(*,*) " file name obtained from the object id is incorrect"
total_error = total_error + 1
END IF
! Use a buffer which is the exact size needed to hold the filename
CALL h5fget_name_f(obj_id, filename_exact, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(name_size .NE. len_filename)THEN
WRITE(*,*) " file name size obtained from the object id is incorrect"
total_error = total_error + 1
ENDIF
IF(filename_exact .NE. TRIM(fix_filename)) THEN
WRITE(*,*) " file name obtained from the object id is incorrect"
total_error = total_error + 1
END IF
! Use a buffer which is smaller than needed to hold the filename
CALL h5fget_name_f(obj_id, filename_sm, name_size, error)
CALL check("h5fget_name_f",error,total_error)
IF(name_size .NE. len_filename)THEN
WRITE(*,*) " file name size obtained from the object id is incorrect"
total_error = total_error + 1
ENDIF
IF(filename_sm(1:len_filename-sm_len) .NE. fix_filename(1:len_filename-sm_len)) THEN
WRITE(*,*) " file name obtained from the object id is incorrect"
total_error = total_error + 1
END IF
END SUBROUTINE check_get_name
! The following subroutine tests h5fget_name_f.
! It creates the file which has name "filename.h5" and
! tests that h5fget_name_f also returns the name "filename.h5"
!
SUBROUTINE get_name_test(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=*), PARAMETER :: filename = "filename"
CHARACTER(LEN=80) :: fix_filename
INTEGER :: len_filename
INTEGER(HID_T) :: file_id ! File identifier
INTEGER(HID_T) :: g_id ! Group identifier
!
! Flag to check operation success
!
INTEGER :: error
!
! Create file "filename.h5" 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 group.
!
CALL h5gopen_f(file_id,"/",g_id, error)
CALL check("h5gopen_f",error,total_error)
len_filename = LEN_TRIM(fix_filename)
CALL check_get_name(file_id, fix_filename, len_filename, total_error)
CALL check_get_name(g_id, fix_filename, len_filename, total_error)
! Close the group.
!
CALL h5gclose_f(g_id, error)
CALL check("h5gclose_f",error,total_error)
!
! Close the file identifiers.
!
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 get_name_test
!
! The following example demonstrates how to get creation property list,
! and access property list.
! We first create a file using the default creation and access property
! list. Then, the file was closed and reopened. We then get the
! creation and access property lists of the first file. The second file is
! created using the got property lists
SUBROUTINE plisttest(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
!
!file names are "plist1.h5" and "plist2.h5"
!
CHARACTER(LEN=6), PARAMETER :: filename1 = "plist1"
CHARACTER(LEN=80) :: fix_filename1
CHARACTER(LEN=6), PARAMETER :: filename2 = "plist2"
CHARACTER(LEN=80) :: fix_filename2
INTEGER(HID_T) :: file1_id, file2_id ! File identifiers
INTEGER(HID_T) :: prop_id ! File creation property list identifier
INTEGER(HID_T) :: access_id ! File Access property list identifier
!flag to check operation success
INTEGER :: error
!file status
LOGICAL :: status
!
!Create a file1 using default properties.
!
CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error)
if (error .ne. 0) then
write(*,*) "Cannot modify file name"
CALL h5_exit_f(1)
endif
CALL h5fcreate_f(fix_filename1, H5F_ACC_TRUNC_F, file1_id, error)
CALL check("h5fcreate_f",error,total_error)
!
!Terminate access to the file.
!
CALL h5fclose_f(file1_id, error)
CALL check("h5fclose_f",error,total_error)
!
!Open an existing file.
!
CALL h5fopen_f (fix_filename1, H5F_ACC_RDWR_F, file1_id, error)
CALL check("h5fopen_f",error,total_error)
!
!get the creation property list.
!
CALL h5fget_create_plist_f(file1_id, prop_id, error)
CALL check("h5fget_create_plist_f",error,total_error)
!
!get the access property list.
!
CALL h5fget_access_plist_f(file1_id, access_id, error)
CALL check("h5fget_access_plist_f",error,total_error)
!
!based on the creation property list id and access property list id
!create a new file
!
CALL h5_fixname_f(filename2, fix_filename2, H5P_DEFAULT_F, error)
if (error .ne. 0) then
write(*,*) "Cannot modify file name"
CALL h5_exit_f(1)
endif
CALL h5fcreate_f(fix_filename2, H5F_ACC_TRUNC_F, file2_id, error, &
prop_id, access_id)
CALL check("h5create_f",error,total_error)
!
!Close all the property lists.
!
CALL h5pclose_f(prop_id, error)
CALL check("h5pclose_f",error,total_error)
CALL h5pclose_f(access_id, error)
CALL check("h5pclose_f",error,total_error)
!
!Terminate access to the files.
!
CALL h5fclose_f(file1_id, error)
CALL check("h5fclose_f",error,total_error)
CALL h5fclose_f(file2_id, error)
CALL check("h5fclose_f",error,total_error)
! Test file deletion
CALL h5fis_accessible_f(filename1, status, error)
CALL check("h5fis_accessible_f",error,total_error)
IF ( .NOT. status ) THEN
WRITE(*,*) "ERROR: File ", filename1, " is not accessible as hdf5"
END IF
CALL h5fdelete_f(filename1, error, H5P_DEFAULT_F)
CALL check("h5fdelete_f", error, total_error)
INQUIRE(FILE=filename1, EXIST=status)
IF ( status ) THEN
WRITE(*,*) "ERROR: File ", filename1, " was not removed by H5Fdelete_f"
END IF
CALL h5fis_accessible_f(filename2, status, error)
CALL check("h5fis_accessible_f",error,total_error)
IF ( .NOT. status ) THEN
WRITE(*,*) "ERROR: File ", filename2, " is not accessible as hdf5"
total_error=total_error + 1
END IF
CALL h5fdelete_f(filename2, error)
CALL check("h5fdelete_f", error, total_error)
INQUIRE(FILE=filename2, EXIST=status)
IF ( status ) THEN
WRITE(*,*) "ERROR: File ", filename2, " was not removed by H5Fdelete_f"
total_error=total_error + 1
END IF
RETURN
END SUBROUTINE plisttest
!
! The following subroutine tests h5pget(set)_fclose_degree_f
!
SUBROUTINE file_close(cleanup, total_error)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
INTEGER :: error
!
CHARACTER(LEN=10), PARAMETER :: filename = "file_close"
CHARACTER(LEN=80) :: fix_filename
INTEGER(HID_T) :: fid, fid_d, fid1, fid2, fid3 ! File identifiers
INTEGER(HID_T) :: fapl, fapl1, fapl2, fapl3 ! File access identifiers
INTEGER(HID_T) :: fid_d_fapl, fid1_fapl ! File access identifiers
LOGICAL :: flag
INTEGER(SIZE_T) :: obj_count, obj_countf
INTEGER(HID_T), ALLOCATABLE, DIMENSION(:) :: obj_ids
INTEGER(SIZE_T) :: i
CALL h5eset_auto_f(0, error)
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, fid, error)
CALL check("h5fcreate_f",error,total_error)
CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
CALL check("h5pcreate_f",error,total_error)
CALL h5pset_fclose_degree_f(fapl, H5F_CLOSE_DEFAULT_F, error)
CALL check("h5pset_fclose_degree_f",error,total_error)
CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl1, error)
CALL check("h5pcreate_f",error,total_error)
CALL h5pset_fclose_degree_f(fapl1, H5F_CLOSE_WEAK_F, error)
CALL check("h5pset_fclose_degree_f",error,total_error)
CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl2, error)
CALL check("h5pcreate_f",error,total_error)
CALL h5pset_fclose_degree_f(fapl2, H5F_CLOSE_SEMI_F, error)
CALL check("h5pset_fclose_degree_f",error,total_error)
CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl3, error)
CALL check("h5pcreate_f",error,total_error)
CALL h5pset_fclose_degree_f(fapl3, H5F_CLOSE_STRONG_F, error)
CALL check("h5pset_fclose_degree_f",error,total_error)
CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, fid1, error, access_prp=fapl1)
CALL check("h5fopen_f",error,total_error)
CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, fid_d, error, access_prp=fapl)
CALL check("h5fopen_f",error,total_error)
CALL h5fget_access_plist_f(fid1, fid1_fapl, error)
CALL check("h5fget_access_plist_f",error,total_error)
CALL h5fget_access_plist_f(fid_d, fid_d_fapl, error)
CALL check("h5fget_access_plist_f",error,total_error)
CALL h5pequal_f(fid_d_fapl, fid1_fapl, flag, error)
CALL check("h5pequal_f",error,total_error)
if (.NOT. flag) then
write(*,*) " File access lists should be equal, error "
total_error=total_error + 1
endif
CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, fid2, error, access_prp=fapl2)
if( error .ne. -1) then
total_error = total_error + 1
write(*,*) " Open with H5F_CLOSE_SEMI should fail "
endif
CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, fid3, error, access_prp=fapl3)
if( error .ne. -1) then
total_error = total_error + 1
write(*,*) " Open with H5F_CLOSE_STRONG should fail "
endif
CALL h5fget_obj_count_f(fid1, H5F_OBJ_ALL_F, obj_count, error)
CALL check("h5fget_obj_count_f",error,total_error)
if(error .eq.0 .and. obj_count .ne. 3) then
total_error = total_error + 1
write(*,*) "Wrong number of open objects reported, error"
endif
CALL h5fget_obj_count_f(fid1, H5F_OBJ_FILE_F, obj_countf, error)
CALL check("h5fget_obj_count_f",error,total_error)
if(error .eq.0 .and. obj_countf .ne. 3) then
total_error = total_error + 1
write(*,*) "Wrong number of open objects reported, error"
endif
allocate(obj_ids(obj_countf), stat = error)
CALL h5fget_obj_ids_f(fid, H5F_OBJ_FILE_F, obj_countf, obj_ids, error)
CALL check("h5fget_obj_ids_f",error,total_error)
if(error .eq. 0) then
do i = 1, obj_countf
CALL h5fclose_f(obj_ids(i), error)
CALL check("h5fclose_f",error,total_error)
enddo
endif
CALL h5fclose_f(fid, error)
if(error .eq. 0) then
total_error = total_error + 1
write(*,*) "File should be closed at this point, error"
endif
CALL h5fclose_f(fid1, error)
if(error .eq. 0) then
total_error = total_error + 1
write(*,*) "File should be closed at this point, error"
endif
CALL h5fclose_f(fid_d, error)
if(error .eq. 0) then
total_error = total_error + 1
write(*,*) "File should be closed at this point, error"
endif
if(cleanup) then
CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
endif
deallocate(obj_ids)
RETURN
END SUBROUTINE file_close
!
! The following subroutine tests h5fget_freespace_f
!
SUBROUTINE file_space(filename, cleanup, total_error)
IMPLICIT NONE
CHARACTER(*), INTENT(IN) :: filename
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
INTEGER :: error
!
CHARACTER(LEN=3), PARAMETER :: grpname = "grp"
CHARACTER(LEN=80) :: fix_filename
INTEGER(HID_T) :: fid ! File identifiers
INTEGER(HSSIZE_T) :: free_space
INTEGER(HID_T) :: group_id ! Group identifier
INTEGER(HID_T) :: fcpl
INTEGER(HSIZE_T), PARAMETER :: set_usrblck_size = 512
INTEGER(HSIZE_T) :: usrblck_size
CALL h5eset_auto_f(0, error)
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 h5pcreate_f(H5P_FILE_CREATE_F, fcpl, error)
CALL check("h5pcreate_f",error, total_error)
CALL H5Pset_userblock_f(fcpl, set_usrblck_size, error )
CALL check("h5pset_userblock_f", error, total_error)
CALL H5Pget_userblock_f(fcpl, usrblck_size, error )
CALL check("h5pget_userblock_f", error, total_error)
IF(usrblck_size .NE. set_usrblck_size) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong size of a user block, ", usrblck_size
ENDIF
CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error, creation_prp=fcpl )
CALL check("h5fcreate_f",error,total_error)
CALL h5pclose_f(fcpl, error)
CALL check("H5Pclose_f", error, total_error)
CALL h5fget_freespace_f(fid, free_space, error)
CALL check("h5fget_freespace_f",error,total_error)
IF(error .EQ.0 .AND. free_space .NE. 1853) THEN
total_error = total_error + 1
WRITE(*,*) "1: Wrong amount of free space reported, ", free_space
ENDIF
! Create group in the file.
CALL h5gcreate_f(fid, grpname, group_id, error)
CALL check("h5gcreate_f",error,total_error)
! Close group
CALL h5gclose_f(group_id, error)
CALL check("h5gclose_f", error, total_error)
! Check the free space now
CALL h5fget_freespace_f(fid, free_space, error)
CALL check("h5fget_freespace_f",error,total_error)
IF(error .EQ.0 .AND. free_space .NE. 1706) THEN
total_error = total_error + 1
WRITE(*,*) "2: Wrong amount of free space reported, ", free_space
ENDIF
!Unlink the group
CALL h5gunlink_f(fid, grpname, error)
CALL check("h5gunlink_f", error, total_error)
! Check the free space now
CALL h5fget_freespace_f(fid, free_space, error)
CALL check("h5fget_freespace_f",error,total_error)
IF(error .EQ.0 .AND. free_space .NE. 1853) THEN
total_error = total_error + 1
WRITE(*,*) "3: Wrong amount of free space reported, ", free_space
ENDIF
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
RETURN
END SUBROUTINE file_space
!
! The following subroutine tests h5fget_info_f
!
SUBROUTINE test_file_info(filename, cleanup, total_error)
IMPLICIT NONE
CHARACTER(*), INTENT(IN) :: filename
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(INOUT) :: total_error
INTEGER :: error
!
CHARACTER(LEN=3), PARAMETER :: grpname = "grp"
CHARACTER(LEN=80) :: fix_filename
INTEGER(HID_T) :: fid ! File identifiers
INTEGER(HID_T) :: group_id ! Group identifier
TYPE(H5F_INFO_T) :: file_info
INTEGER(HID_T) :: fapl, fcpl
INTEGER :: strategy
LOGICAL :: persist
INTEGER(HSIZE_T) :: threshold, fsp_size
CALL h5eset_auto_f(0, error)
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 h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
CALL check("h5pcreate_f",error, total_error)
CALL h5pcreate_f(H5P_FILE_CREATE_F, fcpl, error)
CALL check("h5pcreate_f",error, total_error)
CALL h5pset_libver_bounds_f(fapl, H5F_LIBVER_V114_F, H5F_LIBVER_V114_F, error)
CALL check("h5pset_libver_bounds_f",error, total_error)
CALL h5pset_file_space_strategy_f(fcpl, H5F_FSPACE_STRATEGY_PAGE_F, .TRUE., 4_HSIZE_T, error)
CALL check("h5pset_file_space_strategy_f",error, total_error)
CALL h5pget_file_space_strategy_f(fcpl, strategy, persist, threshold, error)
CALL check("h5pget_file_space_strategy_f",error, total_error)
IF(strategy .NE. H5F_FSPACE_STRATEGY_PAGE_F) THEN
total_error = total_error + 1
WRITE(*,*) "h5pget_file_space_strategy_f: wrong strategy, ",strategy
ENDIF
IF(persist .NEQV. .TRUE.) THEN
total_error = total_error + 1
WRITE(*,*) "h5pget_file_space_strategy_f: wrong persist, ",persist
ENDIF
IF(threshold .NE. 4_HSIZE_T) THEN
total_error = total_error + 1
WRITE(*,*) "h5pget_file_space_strategy_f: wrong threshold, ",threshold
ENDIF
CALL h5pset_file_space_page_size_f(fcpl, 512_HSIZE_T, error)
CALL check("H5Pset_file_space_page_size_f",error, total_error)
CALL h5pget_file_space_page_size_f(fcpl, fsp_size, error)
CALL check("H5Pset_file_space_page_size_f",error, total_error)
IF(fsp_size .NE. 512_HSIZE_T) THEN
total_error = total_error + 1
WRITE(*,*) "h5pget_file_space_page_size_f: wrong size, ",fsp_size
ENDIF
CALL h5pset_alignment_f(fapl, 1_HSIZE_T, 1024_HSIZE_T, error)
CALL check("h5pset_alignment_f",error, total_error)
CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl, creation_prp=fcpl)
CALL check("h5fcreate_f",error,total_error)
! Create group in the file.
CALL h5gcreate_f(fid, grpname, group_id, error)
CALL check("h5gcreate_f",error,total_error)
! Close group
CALL h5gclose_f(group_id, error)
CALL check("h5gclose_f", error, total_error)
!Unlink the group
CALL h5gunlink_f(fid, grpname, error)
CALL check("h5gunlink_f", error, total_error)
! Check H5Fget_info_f
CALL h5fget_info_f(fid, file_info, error)
CALL check("h5fget_info_f", error, total_error)
IF(file_info%super%version .NE. 3) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong super%version, ",file_info%free%tot_space
ENDIF
IF(file_info%super%super_size .NE. 48) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong super%super_size, ",file_info%free%tot_space
ENDIF
IF(file_info%super%super_ext_size .NE. 156) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong super%super_ext_size, ",file_info%super%super_ext_size
ENDIF
IF(file_info%free%version .NE. 0) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong free%version, ",file_info%free%version
ENDIF
IF(file_info%free%tot_space .NE. 161) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong free%tot_space, ",file_info%free%tot_space
ENDIF
IF(file_info%sohm%version.NE. 0) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong sohm%version ",file_info%sohm%version
ENDIF
IF(file_info%sohm%hdr_size.NE. 0) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong sohm%hdr_size ",file_info%sohm%hdr_size
ENDIF
IF(file_info%sohm%msgs_info%heap_size.NE. 0) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong sohm%msgs_info%heap_size ",file_info%sohm%msgs_info%heap_size
ENDIF
IF(file_info%sohm%msgs_info%index_size.NE. 0) THEN
total_error = total_error + 1
WRITE(*,*) "Wrong sohm%msgs_info%heap_size ",file_info%sohm%msgs_info%index_size
ENDIF
CALL h5fclose_f(fid, error)
CALL check("h5fclose_f",error,total_error)
CALL h5pclose_f(fapl, error)
CALL check("H5Pclose_f", error, total_error)
CALL h5pclose_f(fcpl, error)
CALL check("H5Pclose_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 test_file_info
SUBROUTINE test_get_file_image(total_error)
!
! Tests the wrapper for h5fget_file_image
!
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error ! returns error
CHARACTER(kind=c_char), ALLOCATABLE, DIMENSION(:), TARGET :: file_image_ptr ! Image from file
CHARACTER(kind=c_char), ALLOCATABLE, DIMENSION(:), TARGET :: image_ptr ! Image from h5fget_file_image_f
INTEGER, DIMENSION(1:100), TARGET :: data ! Write data
INTEGER :: file_sz
INTEGER(size_t) :: i
INTEGER(hid_t) :: file_id = -1 ! File identifier
INTEGER(hid_t) :: dset_id = -1 ! Dataset identifier
INTEGER(hid_t) :: space_id = -1 ! Dataspace identifier
INTEGER(hsize_t), DIMENSION(1:2) :: dims ! Dataset dimensions
INTEGER(size_t) :: itmp_a ! General purpose integer
INTEGER(size_t) :: image_size ! Size of image
TYPE(C_PTR) :: f_ptr ! Pointer
INTEGER(hid_t) :: fapl ! File access property
INTEGER :: error ! Error flag
CHARACTER(LEN=18), PARAMETER :: filename="tget_file_image.h5"
! Create new properties for file access
CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
CALL check("h5pcreate_f", error, total_error)
! Set standard I/O driver
CALL h5pset_fapl_stdio_f(fapl, error)
CALL check("h5pset_fapl_stdio_f", error, total_error)
! Create the file
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl)
CALL check("h5fcreate_f", error, total_error)
! Set up data space for new data set
dims(1:2) = (/10,10/)
CALL h5screate_simple_f(2, dims, space_id, error)
CALL check("h5screate_simple_f", error, total_error)
! Create a dataset
CALL h5dcreate_f(file_id, "dset 0", H5T_NATIVE_INTEGER, space_id, dset_id, error)
CALL check("h5dcreate_f", error, total_error)
! Write some data to the data set
DO i = 1, 100
data(i) = INT(i)
ENDDO
f_ptr = C_LOC(data(1))
CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
! Flush the file
CALL h5fflush_f(file_id, H5F_SCOPE_GLOBAL_F, error)
CALL check("h5fflush_f",error, total_error)
! Open the test file using standard I/O calls
OPEN(UNIT=10,FILE=filename, ACCESS='STREAM')
! Get the size of the test file
!
! Since we use the eoa to calculate the image size, the file size
! may be larger. This is OK, as long as (in this specialized instance)
! the remainder of the file is all '\0's.
!
! With latest mods to truncate call in core file drive,
! file size should match image size; get the file size
INQUIRE(UNIT=10, SIZE=file_sz)
CLOSE(UNIT=10)
! I. Get buffer size needed to hold the buffer
! A. Preferred way to get the size
f_ptr = C_NULL_PTR
CALL h5fget_file_image_f(file_id, f_ptr, INT(0, size_t), error, image_size)
CALL check("h5fget_file_image_f",error, total_error)
CALL verify("h5fget_file_image_f", file_sz, INT(image_size), total_error)
! B. f_ptr set to point to an incorrect buffer, should pass anyway
f_ptr = C_LOC(data(1))
itmp_a = 1
CALL h5fget_file_image_f(file_id, f_ptr, itmp_a, error, image_size)
CALL check("h5fget_file_image_f",error, total_error)
CALL verify("h5fget_file_image_f", INT(itmp_a), 1, total_error) ! Routine should not change the value
CALL verify("h5fget_file_image_f", file_sz, INT(image_size), total_error)
! Allocate a buffer of the appropriate size
ALLOCATE(image_ptr(1:image_size))
! Load the image of the file into the buffer
f_ptr = C_LOC(image_ptr(1)(1:1))
CALL h5fget_file_image_f(file_id, f_ptr, image_size, error)
CALL check("h5fget_file_image_f",error, total_error)
! Close dset and space
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f", error, total_error)
CALL h5sclose_f(space_id, error)
CALL check("h5sclose_f", error, total_error)
! Close the test file
CALL h5fclose_f(file_id, error)
CALL check("h5fclose_f",error, total_error)
! Allocate a buffer for the test file image
ALLOCATE(file_image_ptr(1:image_size))
! Open the test file using standard I/O calls
OPEN(UNIT=10,FILE=filename, FORM='UNFORMATTED', ACCESS='STREAM')
! Read the test file from disk into the buffer
DO i = 1, image_size
READ(10) file_image_ptr(i)
ENDDO
CLOSE(10)
! verify the file and the image contain the same data
DO i = 1, image_size
! convert one byte to an unsigned integer
IF( ICHAR(file_image_ptr(i)) .NE. ICHAR(image_ptr(i)))THEN
total_error = total_error + 1
EXIT
ENDIF
ENDDO
! release resources
DEALLOCATE(file_image_ptr,image_ptr)
END SUBROUTINE test_get_file_image
END MODULE TH5F
Reference in New Issue View Git Blame Copy Permalink