mirror of
https://github.com/HDFGroup/hdf5.git
synced 2024-11-27 02:10:55 +08:00
89fbe00dec
* commit '54957d37f5aa73912763dbb6e308555e863c43f4': Commit copyright header change for src/H5PLpkg.c which was added after running script to make changes. Add new files in release_docs to MANIFEST. Cimmit changes to Makefile.in(s) and H5PL.c that resulted from running autogen.sh. Merge pull request #407 in HDFFV/hdf5 from ~LRKNOX/hdf5_lrk:hdf5_1_10_1 to hdf5_1_10_1 Change copyright headers to replace url referring to file to be removed and replace it with new url for COPYING file.
317 lines
9.2 KiB
Fortran
317 lines
9.2 KiB
Fortran
!****h* root/fortran/test/tH5L_F03.f90
|
|
!
|
|
! NAME
|
|
! tH5L_F03.f90
|
|
!
|
|
! FUNCTION
|
|
! Test FORTRAN HDF5 H5L APIs which are dependent on FORTRAN 2003
|
|
! features.
|
|
!
|
|
! COPYRIGHT
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
! Copyright by The HDF Group. *
|
|
! Copyright by the Board of Trustees of the University of Illinois. *
|
|
! 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 COPYING file, which can be found at the root of the source code *
|
|
! distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases. *
|
|
! If you do not have access to either file, you may request a copy from *
|
|
! help@hdfgroup.org. *
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
!
|
|
! USES
|
|
! liter_cb_mod
|
|
!
|
|
! CONTAINS SUBROUTINES
|
|
! test_iter_group
|
|
!
|
|
!*****
|
|
MODULE liter_cb_mod
|
|
|
|
USE HDF5
|
|
USE TH5_MISC
|
|
USE TH5_MISC_GEN
|
|
USE, INTRINSIC :: ISO_C_BINDING
|
|
IMPLICIT NONE
|
|
|
|
TYPE iter_enum
|
|
INTEGER RET_ZERO
|
|
INTEGER RET_TWO
|
|
INTEGER RET_CHANGE
|
|
INTEGER RET_CHANGE2
|
|
END TYPE iter_enum
|
|
|
|
! Custom group iteration callback data
|
|
TYPE, bind(c) :: iter_info
|
|
CHARACTER(KIND=C_CHAR), DIMENSION(1:10) :: name ! The name of the object
|
|
INTEGER(c_int) :: TYPE ! The TYPE of the object
|
|
INTEGER(c_int) :: command ! The TYPE of RETURN value
|
|
END TYPE iter_info
|
|
|
|
CONTAINS
|
|
|
|
!***************************************************************
|
|
!**
|
|
!** liter_cb(): Custom link iteration callback routine.
|
|
!**
|
|
!***************************************************************
|
|
|
|
INTEGER(KIND=C_INT) FUNCTION liter_cb(group, name, link_info, op_data) bind(C)
|
|
|
|
IMPLICIT NONE
|
|
|
|
INTEGER(HID_T), VALUE :: group
|
|
CHARACTER(LEN=1), DIMENSION(1:10) :: name
|
|
|
|
|
|
TYPE (H5L_info_t) :: link_info
|
|
|
|
TYPE(iter_info) :: op_data
|
|
|
|
INTEGER, SAVE :: count
|
|
INTEGER, SAVE :: count2
|
|
|
|
!!$
|
|
!!$ iter_info *info = (iter_info *)op_data;
|
|
!!$ static int count = 0;
|
|
!!$ static int count2 = 0;
|
|
|
|
op_data%name(1:10) = name(1:10)
|
|
|
|
SELECT CASE (op_data%command)
|
|
|
|
CASE(0)
|
|
liter_cb = 0
|
|
CASE(2)
|
|
liter_cb = 2
|
|
CASE(3)
|
|
count = count + 1
|
|
IF(count.GT.10) THEN
|
|
liter_cb = 1
|
|
ELSE
|
|
liter_cb = 0
|
|
ENDIF
|
|
CASE(4)
|
|
count2 = count2 + 1
|
|
IF(count2.GT.10) THEN
|
|
liter_cb = 1
|
|
ELSE
|
|
liter_cb = 0
|
|
ENDIF
|
|
END SELECT
|
|
|
|
END FUNCTION liter_cb
|
|
END MODULE liter_cb_mod
|
|
|
|
MODULE TH5L_F03
|
|
|
|
CONTAINS
|
|
|
|
! *****************************************
|
|
! *** H 5 L T E S T S
|
|
! *****************************************
|
|
|
|
|
|
!***************************************************************
|
|
!**
|
|
!** test_iter_group(): Test group iteration functionality
|
|
!**
|
|
!***************************************************************
|
|
SUBROUTINE test_iter_group(total_error)
|
|
|
|
USE liter_cb_mod
|
|
IMPLICIT NONE
|
|
|
|
INTEGER, INTENT(INOUT) :: total_error
|
|
INTEGER(HID_T) :: fapl
|
|
INTEGER(HID_T) :: file ! File ID
|
|
INTEGER(hid_t) :: dataset ! Dataset ID
|
|
INTEGER(hid_t) :: datatype ! Common datatype ID
|
|
INTEGER(hid_t) :: filespace ! Common dataspace ID
|
|
INTEGER(hid_t) :: grp ! Group ID
|
|
INTEGER i,j ! counting variable
|
|
INTEGER(hsize_t) idx ! Index in the group
|
|
CHARACTER(LEN=11) :: DATAFILE = "titerate.h5"
|
|
INTEGER, PARAMETER :: ndatasets = 50
|
|
CHARACTER(LEN=10) :: name ! temporary name buffer
|
|
CHARACTER(LEN=10), DIMENSION(1:ndatasets+2) :: lnames ! Names of the links created
|
|
|
|
TYPE(iter_info), TARGET :: info
|
|
|
|
INTEGER :: error
|
|
INTEGER :: ret_value
|
|
TYPE(C_FUNPTR) :: f1
|
|
TYPE(C_PTR) :: f2
|
|
CHARACTER(LEN=2) :: ichr2
|
|
CHARACTER(LEN=10) :: ichr10
|
|
|
|
! Get the default FAPL
|
|
CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
|
|
CALL check("h5pcreate_f", error, total_error)
|
|
|
|
! Set the "use the latest version of the format" bounds for creating objects in the file
|
|
CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error)
|
|
CALL check("H5Pset_libver_bounds_f",error, total_error)
|
|
|
|
! Create the test file with the datasets
|
|
CALL h5fcreate_f(DATAFILE, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl)
|
|
CALL check("h5fcreate_f", error, total_error)
|
|
|
|
! Test iterating over empty group
|
|
idx = 0
|
|
info%command = 0
|
|
f1 = C_FUNLOC(liter_cb)
|
|
f2 = C_LOC(info)
|
|
|
|
|
|
CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
|
|
CALL check("H5Literate_f", error, total_error)
|
|
|
|
CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
|
|
CALL check("H5Tcopy_f", error, total_error)
|
|
|
|
CALL H5Screate_f(H5S_SCALAR_F, filespace, error)
|
|
CALL check("H5Screate_f", error, total_error)
|
|
|
|
DO i = 1, ndatasets
|
|
WRITE(ichr2, '(I2.2)') i
|
|
|
|
name = 'Dataset '//ichr2
|
|
|
|
CALL h5dcreate_f(file, name, datatype, filespace, dataset, error)
|
|
CALL check("H5dcreate_f", error, total_error)
|
|
|
|
lnames(i) = name
|
|
|
|
CALL h5dclose_f(dataset,error)
|
|
CALL check("H5dclose_f", error, total_error)
|
|
|
|
ENDDO
|
|
|
|
! Create a group and named datatype under root group for testing
|
|
|
|
CALL H5Gcreate_f(file, "grp0000000", grp, error)
|
|
CALL check("H5Gcreate_f", error, total_error)
|
|
|
|
lnames(ndatasets+2) = "grp0000000"
|
|
|
|
!!$
|
|
!!$ lnames[NDATASETS] = HDstrdup("grp");
|
|
!!$ CHECK(lnames[NDATASETS], NULL, "strdup");
|
|
!!$
|
|
|
|
CALL H5Tcommit_f(file, "dtype00000", datatype, error)
|
|
CALL check("H5Tcommit_f", error, total_error)
|
|
|
|
lnames(ndatasets+1) = "dtype00000"
|
|
|
|
! Close everything up
|
|
|
|
CALL H5Tclose_f(datatype, error)
|
|
CALL check("H5Tclose_f", error, total_error)
|
|
|
|
CALL H5Gclose_f(grp, error)
|
|
CALL check("H5Gclose_f", error, total_error)
|
|
|
|
CALL H5Sclose_f(filespace, error)
|
|
CALL check("H5Sclose_f", error, total_error)
|
|
|
|
CALL H5Fclose_f(file, error)
|
|
CALL check("H5Fclose_f", error, total_error)
|
|
|
|
! Iterate through the datasets in the root group in various ways
|
|
CALL H5Fopen_f(DATAFILE, H5F_ACC_RDONLY_F, file, error, access_prp=fapl)
|
|
CALL check("h5fopen_f", error, total_error)
|
|
|
|
! Test all objects in group, when callback always returns 0
|
|
info%command = 0
|
|
idx = 0
|
|
CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
|
|
IF(ret_value.GT.0)THEN
|
|
PRINT*,"ERROR: Group iteration function didn't return zero correctly!"
|
|
CALL verify("H5Literate_f", error, -1, total_error)
|
|
ENDIF
|
|
|
|
! Test all objects in group, when callback always returns 1
|
|
! This also tests the "restarting" ability, because the index changes
|
|
|
|
info%command = 2
|
|
idx = 0
|
|
i = 0
|
|
f1 = C_FUNLOC(liter_cb)
|
|
f2 = C_LOC(info)
|
|
DO
|
|
CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
|
|
IF(error.LT.0) EXIT
|
|
! Verify return value from iterator gets propagated correctly
|
|
CALL verify("H5Literate", ret_value, 2, total_error)
|
|
! Increment the number of times "2" is returned
|
|
i = i + 1
|
|
! Verify that the index is the correct value
|
|
CALL verify("H5Literate", INT(idx), INT(i), total_error)
|
|
IF(idx .GT.ndatasets+2)THEN
|
|
PRINT*,"ERROR: Group iteration function walked too far!"
|
|
ENDIF
|
|
|
|
! Verify the correct name is retrieved
|
|
DO j = 1, 10
|
|
ichr10(j:j) = info%name(j)(1:1)
|
|
ENDDO
|
|
CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
|
|
IF(i.EQ.52)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIXME- scot
|
|
END DO
|
|
|
|
! put check if did not walk far enough -scot FIXME
|
|
|
|
IF(i .NE. (NDATASETS + 2)) THEN
|
|
CALL verify("H5Literate_f", i, INT(NDATASETS + 2), total_error)
|
|
PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly"
|
|
ENDIF
|
|
|
|
! Test all objects in group, when callback changes return value
|
|
! This also tests the "restarting" ability, because the index changes
|
|
|
|
info%command = 3
|
|
idx = 0
|
|
i = 0
|
|
|
|
f1 = C_FUNLOC(liter_cb)
|
|
f2 = C_LOC(info)
|
|
DO
|
|
|
|
CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
|
|
IF(error.LT.0) EXIT
|
|
CALL verify("H5Literate_f", ret_value, 1, total_error)
|
|
|
|
! Increment the number of times "1" is returned
|
|
i = i + 1
|
|
|
|
! Verify that the index is the correct value
|
|
CALL verify("H5Literate_f", INT(idx), INT(i+10), total_error)
|
|
|
|
IF(idx .GT.ndatasets+2)THEN
|
|
PRINT*,"Group iteration function walked too far!"
|
|
ENDIF
|
|
|
|
DO j = 1, 10
|
|
ichr10(j:j) = info%name(j)(1:1)
|
|
ENDDO
|
|
! Verify that the correct name is retrieved
|
|
CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
|
|
IF(i.EQ.42)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIX- scot
|
|
ENDDO
|
|
|
|
IF(i .NE. 42 .OR. idx .NE. 52)THEN
|
|
PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly!"
|
|
CALL check("H5Literate_f",-1,total_error)
|
|
ENDIF
|
|
|
|
CALL H5Fclose_f(file, error)
|
|
CALL check("H5Fclose_f", error, total_error)
|
|
|
|
END SUBROUTINE test_iter_group
|
|
|
|
END MODULE TH5L_F03
|