From 8a170f1c61b5ec79d6cd8a5d271e6db93483bb49 Mon Sep 17 00:00:00 2001 From: Dana Robinson Date: Tue, 22 Sep 2015 15:44:16 -0500 Subject: [svn-r27859] Merged revisions 27625, 27627, 27647, 27648, 27661, 27668, 27670, 27671, 27674, 27676, 27703, 27716, 27720, 27747, 27754, 27755 from the trunk. Mostly CMake and Fortran changes. Tested on: jam (w/ gcc/gfortran 4.9.3) --- CMakeLists.txt | 35 +- MANIFEST | 60 +- Makefile.in | 1 + c++/Makefile.in | 1 + c++/examples/Makefile.in | 1 + c++/src/Makefile.in | 1 + c++/test/Makefile.in | 1 + config/cmake/ConfigureChecks.cmake | 2 +- config/cmake/cacheinit.cmake | 2 + config/cmake/hdf5-config.cmake.in | 18 +- config/cmake_ext_mod/HDFMacros.cmake | 22 +- config/cmake_ext_mod/HDFUseFortran.cmake | 5 +- config/pgi-fflags | 1 + configure | 8 + configure.ac | 5 +- examples/Makefile.in | 1 + fortran/Makefile.in | 1 + fortran/examples/Makefile.in | 1 + fortran/src/CMakeLists.txt | 11 +- fortran/src/H5config_f.inc.cmake | 3 + fortran/src/H5config_f.inc.in | 3 + fortran/src/Makefile.in | 1 + fortran/test/CMakeLists.txt | 44 +- fortran/test/Makefile.am | 16 +- fortran/test/Makefile.in | 30 +- fortran/test/fflush1.F90 | 157 ++ fortran/test/fflush1.f90 | 157 -- fortran/test/fflush2.F90 | 177 ++ fortran/test/fflush2.f90 | 177 -- fortran/test/fortranlib_test.F90 | 257 +++ fortran/test/fortranlib_test.f90 | 252 --- fortran/test/fortranlib_test_1_8.F90 | 122 ++ fortran/test/fortranlib_test_1_8.f90 | 122 -- fortran/test/fortranlib_test_F03.F90 | 193 +++ fortran/test/fortranlib_test_F03.f90 | 193 --- fortran/test/tH5A.F90 | 624 +++++++ fortran/test/tH5A.f90 | 624 ------- fortran/test/tH5A_1_8.F90 | 2779 ++++++++++++++++++++++++++++++ fortran/test/tH5A_1_8.f90 | 2779 ------------------------------ fortran/test/tH5D.F90 | 630 +++++++ fortran/test/tH5D.f90 | 630 ------- fortran/test/tH5E.F90 | 102 ++ fortran/test/tH5E.f90 | 102 -- fortran/test/tH5E_F03.F90 | 203 +++ fortran/test/tH5E_F03.f90 | 203 --- fortran/test/tH5F.F90 | 782 +++++++++ fortran/test/tH5F.f90 | 782 --------- fortran/test/tH5F_F03.F90 | 179 ++ fortran/test/tH5F_F03.f90 | 179 -- fortran/test/tH5G.F90 | 263 +++ fortran/test/tH5G.f90 | 263 --- fortran/test/tH5G_1_8.F90 | 2126 +++++++++++++++++++++++ fortran/test/tH5G_1_8.f90 | 2126 ----------------------- fortran/test/tH5I.F90 | 321 ++++ fortran/test/tH5I.f90 | 321 ---- fortran/test/tH5L_F03.F90 | 318 ++++ fortran/test/tH5L_F03.f90 | 318 ---- fortran/test/tH5MISC_1_8.F90 | 469 +++++ fortran/test/tH5MISC_1_8.f90 | 469 ----- fortran/test/tH5O.F90 | 793 +++++++++ fortran/test/tH5O.f90 | 793 --------- fortran/test/tH5O_F03.F90 | 555 ++++++ fortran/test/tH5O_F03.f90 | 555 ------ fortran/test/tH5P.F90 | 677 ++++++++ fortran/test/tH5P.f90 | 677 -------- fortran/test/tH5P_F03.F90 | 617 +++++++ fortran/test/tH5P_F03.f90 | 617 ------- fortran/test/tH5R.F90 | 483 ++++++ fortran/test/tH5R.f90 | 483 ------ fortran/test/tH5S.F90 | 298 ++++ fortran/test/tH5S.f90 | 298 ---- fortran/test/tH5Sselect.F90 | 1993 +++++++++++++++++++++ fortran/test/tH5Sselect.f90 | 1993 --------------------- fortran/test/tH5T.F90 | 1149 ++++++++++++ fortran/test/tH5T.f90 | 1149 ------------ fortran/test/tH5VL.F90 | 512 ++++++ fortran/test/tH5VL.f90 | 512 ------ fortran/test/tH5Z.F90 | 419 +++++ fortran/test/tH5Z.f90 | 419 ----- fortran/test/tHDF5.F90 | 46 + fortran/test/tHDF5.f90 | 46 - fortran/test/tHDF5_1_8.F90 | 37 + fortran/test/tHDF5_1_8.f90 | 37 - fortran/test/tHDF5_F03.F90 | 39 + fortran/test/tHDF5_F03.f90 | 39 - fortran/testpar/Makefile.in | 1 + hl/Makefile.in | 1 + hl/c++/Makefile.in | 1 + hl/c++/examples/Makefile.in | 1 + hl/c++/src/Makefile.in | 1 + hl/c++/test/Makefile.in | 1 + hl/examples/Makefile.in | 1 + hl/fortran/Makefile.in | 1 + hl/fortran/examples/Makefile.in | 1 + hl/fortran/src/CMakeLists.txt | 15 +- hl/fortran/src/H5HL_buildiface.F90 | 179 +- hl/fortran/src/H5LTff.F90 | 34 - hl/fortran/src/Makefile.in | 1 + hl/fortran/test/Makefile.in | 1 + hl/fortran/test/tstlite.F90 | 1273 ++++++++------ hl/src/Makefile.in | 1 + hl/test/Makefile.in | 1 + hl/tools/Makefile.in | 1 + hl/tools/gif2h5/Makefile.in | 1 + hl/tools/h5watch/Makefile.in | 1 + src/H5config.h.in | 3 + src/Makefile.in | 1 + test/CMakeTests.cmake | 16 +- test/Makefile.in | 1 + testpar/Makefile.in | 1 + tools/Makefile.in | 1 + tools/h5copy/Makefile.in | 1 + tools/h5diff/Makefile.in | 1 + tools/h5dump/Makefile.in | 1 + tools/h5format_convert/Makefile.in | 1 + tools/h5import/Makefile.in | 1 + tools/h5jam/Makefile.in | 1 + tools/h5ls/Makefile.in | 1 + tools/h5repack/Makefile.in | 1 + tools/h5stat/Makefile.in | 1 + tools/lib/Makefile.in | 1 + tools/misc/Makefile.in | 1 + tools/perform/Makefile.in | 1 + 123 files changed, 18454 insertions(+), 18007 deletions(-) create mode 100644 fortran/test/fflush1.F90 delete mode 100644 fortran/test/fflush1.f90 create mode 100644 fortran/test/fflush2.F90 delete mode 100644 fortran/test/fflush2.f90 create mode 100644 fortran/test/fortranlib_test.F90 delete mode 100644 fortran/test/fortranlib_test.f90 create mode 100644 fortran/test/fortranlib_test_1_8.F90 delete mode 100644 fortran/test/fortranlib_test_1_8.f90 create mode 100644 fortran/test/fortranlib_test_F03.F90 delete mode 100644 fortran/test/fortranlib_test_F03.f90 create mode 100644 fortran/test/tH5A.F90 delete mode 100644 fortran/test/tH5A.f90 create mode 100644 fortran/test/tH5A_1_8.F90 delete mode 100644 fortran/test/tH5A_1_8.f90 create mode 100644 fortran/test/tH5D.F90 delete mode 100644 fortran/test/tH5D.f90 create mode 100644 fortran/test/tH5E.F90 delete mode 100644 fortran/test/tH5E.f90 create mode 100644 fortran/test/tH5E_F03.F90 delete mode 100644 fortran/test/tH5E_F03.f90 create mode 100644 fortran/test/tH5F.F90 delete mode 100644 fortran/test/tH5F.f90 create mode 100644 fortran/test/tH5F_F03.F90 delete mode 100644 fortran/test/tH5F_F03.f90 create mode 100644 fortran/test/tH5G.F90 delete mode 100644 fortran/test/tH5G.f90 create mode 100644 fortran/test/tH5G_1_8.F90 delete mode 100644 fortran/test/tH5G_1_8.f90 create mode 100644 fortran/test/tH5I.F90 delete mode 100644 fortran/test/tH5I.f90 create mode 100644 fortran/test/tH5L_F03.F90 delete mode 100644 fortran/test/tH5L_F03.f90 create mode 100644 fortran/test/tH5MISC_1_8.F90 delete mode 100644 fortran/test/tH5MISC_1_8.f90 create mode 100644 fortran/test/tH5O.F90 delete mode 100644 fortran/test/tH5O.f90 create mode 100644 fortran/test/tH5O_F03.F90 delete mode 100644 fortran/test/tH5O_F03.f90 create mode 100644 fortran/test/tH5P.F90 delete mode 100644 fortran/test/tH5P.f90 create mode 100644 fortran/test/tH5P_F03.F90 delete mode 100644 fortran/test/tH5P_F03.f90 create mode 100644 fortran/test/tH5R.F90 delete mode 100644 fortran/test/tH5R.f90 create mode 100644 fortran/test/tH5S.F90 delete mode 100644 fortran/test/tH5S.f90 create mode 100644 fortran/test/tH5Sselect.F90 delete mode 100644 fortran/test/tH5Sselect.f90 create mode 100644 fortran/test/tH5T.F90 delete mode 100644 fortran/test/tH5T.f90 create mode 100644 fortran/test/tH5VL.F90 delete mode 100644 fortran/test/tH5VL.f90 create mode 100644 fortran/test/tH5Z.F90 delete mode 100644 fortran/test/tH5Z.f90 create mode 100644 fortran/test/tHDF5.F90 delete mode 100644 fortran/test/tHDF5.f90 create mode 100644 fortran/test/tHDF5_1_8.F90 delete mode 100644 fortran/test/tHDF5_1_8.f90 create mode 100644 fortran/test/tHDF5_F03.F90 delete mode 100644 fortran/test/tHDF5_F03.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index c75114e..96d5772 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -614,8 +614,23 @@ if (BUILD_TESTING) CACHE INTEGER "Timeout in seconds for each test (default 1200=20minutes)" ) + + option (HDF5_TEST_VFD "Execute tests with different VFDs" OFF) + mark_as_advanced (HDF5_TEST_VFD) + if (HDF5_TEST_VFD) + option (HDF5_TEST_FHEAP_VFD "Execute tests with different VFDs" ON) + mark_as_advanced (HDF5_TEST_FHEAP_VFD) + endif (HDF5_TEST_VFD) + + option (HDF_TEST_EXPRESS "Control testing framework (0-3)" "0") + mark_as_advanced (HDF_TEST_EXPRESS) + enable_testing () include (CTest) + + include (${HDF5_SOURCE_DIR}/CTestConfig.cmake) + configure_file (${HDF_RESOURCES_DIR}/CTestCustom.cmake ${HDF5_BINARY_DIR}/CTestCustom.ctest @ONLY) + if (NOT HDF5_EXTERNALLY_CONFIGURED) if (EXISTS "${HDF5_SOURCE_DIR}/test" AND IS_DIRECTORY "${HDF5_SOURCE_DIR}/test") add_subdirectory (${HDF5_SOURCE_DIR}/tools/lib ${PROJECT_BINARY_DIR}/tools/lib) @@ -627,16 +642,6 @@ if (BUILD_TESTING) endif (EXISTS "${HDF5_SOURCE_DIR}/testpar" AND IS_DIRECTORY "${HDF5_SOURCE_DIR}/testpar") endif (H5_HAVE_PARALLEL) endif (NOT HDF5_EXTERNALLY_CONFIGURED) - - option (HDF5_TEST_VFD "Execute tests with different VFDs" OFF) - mark_as_advanced (HDF5_TEST_VFD) - if (HDF5_TEST_VFD) - option (HDF5_TEST_FHEAP_VFD "Execute tests with different VFDs" ON) - mark_as_advanced (HDF5_TEST_FHEAP_VFD) - endif (HDF5_TEST_VFD) - - include (${HDF5_SOURCE_DIR}/CTestConfig.cmake) - configure_file (${HDF_RESOURCES_DIR}/CTestCustom.cmake ${HDF5_BINARY_DIR}/CTestCustom.ctest @ONLY) endif (BUILD_TESTING) #----------------------------------------------------------------------------- @@ -691,8 +696,18 @@ if (EXISTS "${HDF5_SOURCE_DIR}/fortran" AND IS_DIRECTORY "${HDF5_SOURCE_DIR}/for endif (NOT ALLOW_UNSUPPORTED) endif (BUILD_SHARED_LIBS AND APPLE) option (HDF5_ENABLE_F2003 "Enable FORTRAN 2003 Standard" ON) + include (${HDF_RESOURCES_EXT_DIR}/HDFUseFortran.cmake) + + message (STATUS "Fortran compiler ID is ${CMAKE_Fortran_COMPILER_ID}") + # Building with PGI requires CMake 3.3 or greater because previous versions + # of CMake add the wrong compiler flag for the PGI Fortran compiler. + if ("${CMAKE_Fortran_COMPILER_ID}" MATCHES "PGI" AND "${CMAKE_VERSION}" VERSION_LESS "3.3") + message (FATAL_ERROR " **** PGI FORTRAN REQUIRES CMAKE VERSION 3.3 OR GREATER **** ") + endif () + include (${HDF_RESOURCES_DIR}/HDF5UseFortran.cmake) + if (HDF5_ENABLE_F2003) if (NOT FORTRAN_HAVE_ISO_C_BINDING) set (HDF5_ENABLE_F2003 OFF) diff --git a/MANIFEST b/MANIFEST index d17dbd9..ddfc274 100644 --- a/MANIFEST +++ b/MANIFEST @@ -236,41 +236,41 @@ ./fortran/test/Makefile.am ./fortran/test/Makefile.in -./fortran/test/fflush1.f90 -./fortran/test/fflush2.f90 -./fortran/test/fortranlib_test.f90 -./fortran/test/fortranlib_test_1_8.f90 -./fortran/test/fortranlib_test_F03.f90 +./fortran/test/fflush1.F90 +./fortran/test/fflush2.F90 +./fortran/test/fortranlib_test.F90 +./fortran/test/fortranlib_test_1_8.F90 +./fortran/test/fortranlib_test_F03.F90 ./fortran/test/H5_test_buildiface.F90 ./fortran/test/t.c ./fortran/test/t.h ./fortran/test/tf.F90 -./fortran/test/tH5A.f90 -./fortran/test/tH5A_1_8.f90 -./fortran/test/tH5D.f90 -./fortran/test/tH5E_F03.f90 -./fortran/test/tH5E.f90 -./fortran/test/tH5F.f90 -./fortran/test/tH5F_F03.f90 -./fortran/test/tH5G.f90 -./fortran/test/tH5G_1_8.f90 -./fortran/test/tH5I.f90 -./fortran/test/tH5L_F03.f90 -./fortran/test/tH5MISC_1_8.f90 -./fortran/test/tH5O.f90 -./fortran/test/tH5O_F03.f90 -./fortran/test/tH5P_F03.f90 -./fortran/test/tH5P.f90 -./fortran/test/tH5R.f90 -./fortran/test/tH5S.f90 -./fortran/test/tH5Sselect.f90 +./fortran/test/tH5A.F90 +./fortran/test/tH5A_1_8.F90 +./fortran/test/tH5D.F90 +./fortran/test/tH5E_F03.F90 +./fortran/test/tH5E.F90 +./fortran/test/tH5F.F90 +./fortran/test/tH5F_F03.F90 +./fortran/test/tH5G.F90 +./fortran/test/tH5G_1_8.F90 +./fortran/test/tH5I.F90 +./fortran/test/tH5L_F03.F90 +./fortran/test/tH5MISC_1_8.F90 +./fortran/test/tH5O.F90 +./fortran/test/tH5O_F03.F90 +./fortran/test/tH5P_F03.F90 +./fortran/test/tH5P.F90 +./fortran/test/tH5R.F90 +./fortran/test/tH5S.F90 +./fortran/test/tH5Sselect.F90 ./fortran/test/tH5T_F03.F90 -./fortran/test/tH5T.f90 -./fortran/test/tH5VL.f90 -./fortran/test/tH5Z.f90 -./fortran/test/tHDF5_1_8.f90 -./fortran/test/tHDF5_F03.f90 -./fortran/test/tHDF5.f90 +./fortran/test/tH5T.F90 +./fortran/test/tH5VL.F90 +./fortran/test/tH5Z.F90 +./fortran/test/tHDF5_1_8.F90 +./fortran/test/tHDF5_F03.F90 +./fortran/test/tHDF5.F90 ./fortran/testpar/Makefile.am ./fortran/testpar/Makefile.in diff --git a/Makefile.in b/Makefile.in index 2e9effd..98fa5aa 100644 --- a/Makefile.in +++ b/Makefile.in @@ -298,6 +298,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/c++/Makefile.in b/c++/Makefile.in index 4ff4906..ff18fff 100644 --- a/c++/Makefile.in +++ b/c++/Makefile.in @@ -458,6 +458,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/c++/examples/Makefile.in b/c++/examples/Makefile.in index 9691b5e..1d7dcbe 100644 --- a/c++/examples/Makefile.in +++ b/c++/examples/Makefile.in @@ -406,6 +406,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/c++/src/Makefile.in b/c++/src/Makefile.in index f2e59b2..cd72f6a 100644 --- a/c++/src/Makefile.in +++ b/c++/src/Makefile.in @@ -469,6 +469,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/c++/test/Makefile.in b/c++/test/Makefile.in index e487e54..380bd32 100644 --- a/c++/test/Makefile.in +++ b/c++/test/Makefile.in @@ -460,6 +460,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/config/cmake/ConfigureChecks.cmake b/config/cmake/ConfigureChecks.cmake index b9f18a9..8bd6f45 100644 --- a/config/cmake/ConfigureChecks.cmake +++ b/config/cmake/ConfigureChecks.cmake @@ -126,7 +126,7 @@ endif (NOT WINDOWS) # Check if Direct I/O driver works #----------------------------------------------------------------------------- if (NOT WINDOWS) - option (HDF5_ENABLE_DIRECT_VFD "Build the Direct I/O Virtual File Driver" ON) + option (HDF5_ENABLE_DIRECT_VFD "Build the Direct I/O Virtual File Driver" OFF) if (HDF5_ENABLE_DIRECT_VFD) set (msg "Performing TEST_DIRECT_VFD_WORKS") set (MACRO_CHECK_FUNCTION_DEFINITIONS "-DTEST_DIRECT_VFD_WORKS -D_GNU_SOURCE ${CMAKE_REQUIRED_FLAGS}") diff --git a/config/cmake/cacheinit.cmake b/config/cmake/cacheinit.cmake index 5b9d2b4..cef6b8f 100644 --- a/config/cmake/cacheinit.cmake +++ b/config/cmake/cacheinit.cmake @@ -48,6 +48,8 @@ set (HDF5_USE_18_API_DEFAULT OFF CACHE BOOL "Use the HDF5 1.8.x API by default" set (HDF5_ENABLE_THREADSAFE OFF CACHE BOOL "(WINDOWS)Enable Threadsafety" FORCE) +set (HDF_TEST_EXPRESS "2" CACHE STRING "Control testing framework (0-3)" FORCE) + set (HDF5_PACKAGE_EXTLIBS OFF CACHE BOOL "(WINDOWS)CPACK - include external libraries" FORCE) set (HDF5_NO_PACKAGES OFF CACHE BOOL "CPACK - Disable packaging" FORCE) diff --git a/config/cmake/hdf5-config.cmake.in b/config/cmake/hdf5-config.cmake.in index adeec55..3577e40 100644 --- a/config/cmake/hdf5-config.cmake.in +++ b/config/cmake/hdf5-config.cmake.in @@ -48,10 +48,6 @@ set (${HDF5_PACKAGE_NAME}_INCLUDE_DIR "@PACKAGE_INCLUDE_INSTALL_DIR@" "${${HDF5_ set (${HDF5_PACKAGE_NAME}_SHARE_DIR "@PACKAGE_SHARE_INSTALL_DIR@") set_and_check (${HDF5_PACKAGE_NAME}_BUILD_DIR "@PACKAGE_CURRENT_BUILD_DIR@") -if (${HDF5_PACKAGE_NAME}_BUILD_FORTRAN) - set (${HDF5_PACKAGE_NAME}_INCLUDE_DIR_FORTRAN "@PACKAGE_INCLUDE_INSTALL_DIR@") -endif () - if (${HDF5_PACKAGE_NAME}_BUILD_CPP_LIB) set (${HDF5_PACKAGE_NAME}_INCLUDE_DIR_CPP "@PACKAGE_INCLUDE_INSTALL_DIR@") endif () @@ -103,9 +99,17 @@ foreach (comp IN LISTS ${HDF5_PACKAGE_NAME}_FIND_COMPONENTS) if (${comp} STREQUAL "shared") list (REMOVE_ITEM ${HDF5_PACKAGE_NAME}_FIND_COMPONENTS ${comp}) set (${HDF5_PACKAGE_NAME}_LIB_TYPE ${${HDF5_PACKAGE_NAME}_LIB_TYPE} ${comp}) + + if (${HDF5_PACKAGE_NAME}_BUILD_FORTRAN) + set (${HDF5_PACKAGE_NAME}_INCLUDE_DIR_FORTRAN "@PACKAGE_INCLUDE_INSTALL_DIR@/shared") + endif () elseif (${comp} STREQUAL "static") list (REMOVE_ITEM ${HDF5_PACKAGE_NAME}_FIND_COMPONENTS ${comp}) set (${HDF5_PACKAGE_NAME}_LIB_TYPE ${${HDF5_PACKAGE_NAME}_LIB_TYPE} ${comp}) + + if (${HDF5_PACKAGE_NAME}_BUILD_FORTRAN) + set (${HDF5_PACKAGE_NAME}_INCLUDE_DIR_FORTRAN "@PACKAGE_INCLUDE_INSTALL_DIR@/static") + endif () endif () endforeach () foreach (libtype IN LISTS ${HDF5_PACKAGE_NAME}_LIB_TYPE) @@ -128,12 +132,12 @@ foreach (libtype IN LISTS ${HDF5_PACKAGE_NAME}_LIB_TYPE) set (hdf5_comp2 "hdf5_hl_f90cstub") set (hdf5_comp "hdf5_hl_fortran") endif () - list (FIND ${HDF5_PACKAGE_NAME}_EXPORT_LIBRARIES "${hdf5_comp}-${libtype}" HAVE_COMP) - if (${HAVE_COMP} LESS 0) + list (FIND ${HDF5_PACKAGE_NAME}_EXPORT_LIBRARIES "${hdf5_comp}-${libtype}" HAVE_COMP) + if (${HAVE_COMP} LESS 0) set (${HDF5_PACKAGE_NAME}_${libtype}_${comp}_FOUND 0) else () if (hdf5_comp2) - list (FIND ${HDF5_PACKAGE_NAME}_EXPORT_LIBRARIES "${hdf5_comp2}-${libtype}" HAVE_COMP2) + list (FIND ${HDF5_PACKAGE_NAME}_EXPORT_LIBRARIES "${hdf5_comp2}-${libtype}" HAVE_COMP2) if (${HAVE_COMP2} LESS 0) set (${HDF5_PACKAGE_NAME}_${libtype}_${comp}_FOUND 0) else () diff --git a/config/cmake_ext_mod/HDFMacros.cmake b/config/cmake_ext_mod/HDFMacros.cmake index d3ac36b..b2c4997 100644 --- a/config/cmake_ext_mod/HDFMacros.cmake +++ b/config/cmake_ext_mod/HDFMacros.cmake @@ -20,7 +20,7 @@ endmacro (IDE_GENERATED_PROPERTIES) macro (IDE_SOURCE_PROPERTIES SOURCE_PATH HEADERS SOURCES) # install (FILES ${HEADERS} # DESTINATION include/R3D/${NAME} - # COMPONENT Headers + # COMPONENT Headers # ) string (REPLACE "/" "\\\\" source_group_path ${SOURCE_PATH} ) @@ -90,7 +90,7 @@ macro (HDF_SET_LIB_OPTIONS libtarget libname libtype) set (LIB_DEBUG_NAME "${libname}_debug") endif (WIN32) endif (${libtype} MATCHES "SHARED") - + set_target_properties (${libtarget} PROPERTIES OUTPUT_NAME_DEBUG ${LIB_DEBUG_NAME} @@ -98,7 +98,7 @@ macro (HDF_SET_LIB_OPTIONS libtarget libname libtype) OUTPUT_NAME_MINSIZEREL ${LIB_RELEASE_NAME} OUTPUT_NAME_RELWITHDEBINFO ${LIB_RELEASE_NAME} ) - + #----- Use MSVC Naming conventions for Shared Libraries if (MINGW AND ${libtype} MATCHES "SHARED") set_target_properties (${libtarget} @@ -176,7 +176,7 @@ macro (TARGET_C_PROPERTIES wintarget libtype addcompileflags addlinkflags) PROPERTIES COMPILE_FLAGS "${addcompileflags}" LINK_FLAGS "${addlinkflags}" - ) + ) endif (MSVC) endmacro (TARGET_C_PROPERTIES) @@ -187,7 +187,7 @@ macro (TARGET_MSVC_PROPERTIES wintarget libtype addcompileflags addlinkflags) PROPERTIES COMPILE_FLAGS "${addcompileflags}" LINK_FLAGS "${addlinkflags}" - ) + ) endif (MSVC) endmacro (TARGET_MSVC_PROPERTIES) @@ -206,13 +206,13 @@ macro (TARGET_FORTRAN_WIN_PROPERTIES forttarget libtype addcompileflags addlinkf PROPERTIES COMPILE_FLAGS "/dll ${addcompileflags}" LINK_FLAGS "/SUBSYSTEM:CONSOLE ${addlinkflags}" - ) + ) else (${libtype} MATCHES "SHARED") set_target_properties (${forttarget} PROPERTIES COMPILE_FLAGS "${addcompileflags}" LINK_FLAGS "/SUBSYSTEM:CONSOLE ${addlinkflags}" - ) + ) endif (${libtype} MATCHES "SHARED") endif (MSVC) endmacro (TARGET_FORTRAN_WIN_PROPERTIES) @@ -235,6 +235,8 @@ macro (HDF_README_PROPERTIES target_fortran) set (BINARY_PLATFORM "${BINARY_PLATFORM} 7") elseif (${CMAKE_SYSTEM_VERSION} MATCHES "6.2") set (BINARY_PLATFORM "${BINARY_PLATFORM} 8") + elseif (${CMAKE_SYSTEM_VERSION} MATCHES "6.3") + set (BINARY_PLATFORM "${BINARY_PLATFORM} 10") endif (${CMAKE_SYSTEM_VERSION} MATCHES "6.1") set (BINARY_PLATFORM "${BINARY_PLATFORM} ${MSVC_C_ARCHITECTURE_ID}") if (${CMAKE_C_COMPILER_VERSION} MATCHES "16.*") @@ -245,6 +247,8 @@ macro (HDF_README_PROPERTIES target_fortran) set (BINARY_PLATFORM "${BINARY_PLATFORM}, using VISUAL STUDIO 2012") elseif (${CMAKE_C_COMPILER_VERSION} MATCHES "18.*") set (BINARY_PLATFORM "${BINARY_PLATFORM}, using VISUAL STUDIO 2013") + elseif (${CMAKE_C_COMPILER_VERSION} MATCHES "19.*") + set (BINARY_PLATFORM "${BINARY_PLATFORM}, using VISUAL STUDIO 2015") else (${CMAKE_C_COMPILER_VERSION} MATCHES "16.*") set (BINARY_PLATFORM "${BINARY_PLATFORM}, using VISUAL STUDIO ${CMAKE_C_COMPILER_VERSION}") endif (${CMAKE_C_COMPILER_VERSION} MATCHES "16.*") @@ -269,9 +273,9 @@ macro (HDF_README_PROPERTIES target_fortran) else (BUILD_SHARED_LIBS) set (LIB_TYPE "Static") endif (BUILD_SHARED_LIBS) - + configure_file ( - ${HDF_RESOURCES_DIR}/README.txt.cmake.in + ${HDF_RESOURCES_DIR}/README.txt.cmake.in ${CMAKE_BINARY_DIR}/README.txt @ONLY ) endmacro (HDF_README_PROPERTIES) diff --git a/config/cmake_ext_mod/HDFUseFortran.cmake b/config/cmake_ext_mod/HDFUseFortran.cmake index c1df8cf..275f2ea 100644 --- a/config/cmake_ext_mod/HDFUseFortran.cmake +++ b/config/cmake_ext_mod/HDFUseFortran.cmake @@ -3,7 +3,7 @@ # #------------------------------------------------------------------------------- ENABLE_LANGUAGE (Fortran) - + #----------------------------------------------------------------------------- # Detect name mangling convention used between Fortran and C #----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ FortranCInterface_HEADER ( ${CMAKE_BINARY_DIR}/FCMangle.h MACRO_NAMESPACE "H5_FC_" SYMBOL_NAMESPACE "H5_FC_" - SYMBOLS mysub mymod:my_sub ) file (STRINGS ${CMAKE_BINARY_DIR}/FCMangle.h CONTENTS REGEX "H5_FC_GLOBAL\\(.*,.*\\) +(.*)") @@ -161,7 +160,7 @@ CHECK_FORTRAN_FEATURE(iso_c_binding IMPLICIT NONE TYPE(C_PTR) :: ptr TYPE(C_FUNPTR) :: funptr - INTEGER(C_INT64_T) :: c_int64_type + INTEGER(C_INT64_T) :: c_int64_type CHARACTER(LEN=80, KIND=c_char), TARGET :: ichr ptr = C_LOC(ichr(1:1)) END PROGRAM diff --git a/config/pgi-fflags b/config/pgi-fflags index 6cb8930..8e574e4 100644 --- a/config/pgi-fflags +++ b/config/pgi-fflags @@ -69,6 +69,7 @@ if test "X-pgf90" = "X-$f9x_vendor"; then # General FC_BASENAME=pgf90 + Fortran_COMPILER_ID=PGI F9XSUFFIXFLAG="" FSEARCH_DIRS="" # Uncomment the following to add something specific for FCFLAGS. diff --git a/configure b/configure index be65714..6d79fdc 100755 --- a/configure +++ b/configure @@ -774,6 +774,7 @@ ac_ct_CC LDFLAGS CFLAGS CC +Fortran_COMPILER_ID PAC_C_MAX_REAL_PRECISION UNAME_INFO enable_static @@ -3885,6 +3886,8 @@ $as_echo "done" >&6; } UNAME_INFO=`uname -a` +Fortran_COMPILER_ID=none + ## ---------------------------------------------------------------------- ## Some platforms have broken basename, and/or xargs programs. Check ## that it actually does what it's supposed to do. Catch this early @@ -8261,6 +8264,11 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu +cat >>confdefs.h <<_ACEOF +#define Fortran_COMPILER_ID $Fortran_COMPILER_ID +_ACEOF + + ## Setting definition if there is a 16 byte fortran integer if `echo $PAC_FC_ALL_INTEGER_KINDS_SIZEOF | grep '16' >/dev/null`; then HAVE_Fortran_INTEGER_SIZEOF_16="1" diff --git a/configure.ac b/configure.ac index 820c2d0..42ba2a2 100644 --- a/configure.ac +++ b/configure.ac @@ -188,6 +188,8 @@ AC_SUBST([enable_shared]) AC_SUBST([enable_static]) AC_SUBST([UNAME_INFO]) UNAME_INFO=`uname -a` AC_SUBST([PAC_C_MAX_REAL_PRECISION]) +AC_SUBST([Fortran_COMPILER_ID]) +Fortran_COMPILER_ID=none ## ---------------------------------------------------------------------- ## Some platforms have broken basename, and/or xargs programs. Check @@ -516,7 +518,8 @@ if test "X$HDF_FORTRAN" = "Xyes"; then AC_SUBST([H5CONFIG_F_RKIND]) AC_SUBST([H5CONFIG_F_RKIND_SIZEOF]) AC_SUBST([H5CONFIG_F_NUM_IKIND]) - AC_SUBST([H5CONFIG_F_IKIND]) + AC_SUBST([H5CONFIG_F_IKIND]) + AC_DEFINE_UNQUOTED([Fortran_COMPILER_ID], $Fortran_COMPILER_ID, [Define Fortran compiler ID]) ## Setting definition if there is a 16 byte fortran integer if `echo $PAC_FC_ALL_INTEGER_KINDS_SIZEOF | grep '16' >/dev/null`; then diff --git a/examples/Makefile.in b/examples/Makefile.in index 94a0b54..e6d2945 100644 --- a/examples/Makefile.in +++ b/examples/Makefile.in @@ -406,6 +406,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/fortran/Makefile.in b/fortran/Makefile.in index 5d5d63e..ca2ea6d 100644 --- a/fortran/Makefile.in +++ b/fortran/Makefile.in @@ -462,6 +462,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/fortran/examples/Makefile.in b/fortran/examples/Makefile.in index 0ee1461..de02876 100644 --- a/fortran/examples/Makefile.in +++ b/fortran/examples/Makefile.in @@ -411,6 +411,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/fortran/src/CMakeLists.txt b/fortran/src/CMakeLists.txt index cf4be30..dc884d5 100644 --- a/fortran/src/CMakeLists.txt +++ b/fortran/src/CMakeLists.txt @@ -70,13 +70,12 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) else (WIN32) set (MODSH_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/shared) endif (WIN32) -else (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) - if (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static/\${BUILD_TYPE}) - else (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static) - endif (WIN32) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) +if (WIN32) + set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static/\${BUILD_TYPE}) +else (WIN32) + set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static) +endif (WIN32) INCLUDE_DIRECTORIES (${HDF5_F90_BINARY_DIR} ${CMAKE_Fortran_MODULE_DIRECTORY}) diff --git a/fortran/src/H5config_f.inc.cmake b/fortran/src/H5config_f.inc.cmake index cc36889..f0b3472 100644 --- a/fortran/src/H5config_f.inc.cmake +++ b/fortran/src/H5config_f.inc.cmake @@ -82,3 +82,6 @@ ! valid INTEGER KINDs (need to have a matching C counter-part) #define H5_H5CONFIG_F_IKIND @H5CONFIG_F_IKIND@ + +! Fortran compiler id +#define H5_Fortran_COMPILER_ID @Fortran_COMPILER_ID@ diff --git a/fortran/src/H5config_f.inc.in b/fortran/src/H5config_f.inc.in index 64c3a0c..9f094d2 100644 --- a/fortran/src/H5config_f.inc.in +++ b/fortran/src/H5config_f.inc.in @@ -57,3 +57,6 @@ ! valid INTEGER KINDs (need to have a matching C counter-part) #undef H5CONFIG_F_IKIND +! Fortran compiler name +#undef Fortran_COMPILER_ID + diff --git a/fortran/src/Makefile.in b/fortran/src/Makefile.in index 582e90e..e5527aa 100644 --- a/fortran/src/Makefile.in +++ b/fortran/src/Makefile.in @@ -506,6 +506,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/fortran/test/CMakeLists.txt b/fortran/test/CMakeLists.txt index 16da168..97830ad 100644 --- a/fortran/test/CMakeLists.txt +++ b/fortran/test/CMakeLists.txt @@ -75,10 +75,27 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) ) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) -set_source_files_properties (tf.F90 ${HDF5_F90_BINARY_DIR}/tf_gen.F90 PROPERTIES LANGUAGE Fortran) -add_library (${HDF5_F90_TEST_LIB_TARGET} STATIC tf.F90 ${HDF5_F90_BINARY_DIR}/tf_gen.F90) +set (HDF5_F90_TF_SRCS + # generated files + ${HDF5_F90_BINARY_DIR}/tf_gen.F90 +) +set_source_files_properties ( + ${HDF5_F90_BINARY_DIR}/tf_gen.F90 + PROPERTIES GENERATED TRUE +) +set_source_files_properties (tf.F90 ${HDF5_F90_BINARY_DIR}/${HDF5_F90_TF_SRCS} PROPERTIES LANGUAGE Fortran) + +set (CMD $) +add_custom_target (H5testgen ALL + COMMAND ${CMD} +#v3.2 BYPRODUCT ${HDF5_F90_BINARY_DIR}/tf_gen.F90 + WORKING_DIRECTORY ${HDF5_F90_BINARY_DIR} + DEPENDS H5_test_buildiface +) + +add_library (${HDF5_F90_TEST_LIB_TARGET} STATIC tf.F90 ${HDF5_F90_TF_SRCS}) if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) - add_library (${HDF5_F90_TEST_LIBSH_TARGET} SHARED tf.F90 ${HDF5_F90_BINARY_DIR}/tf_gen.F90) + add_library (${HDF5_F90_TEST_LIBSH_TARGET} SHARED tf.F90 ${HDF5_F90_TF_SRCS}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) set (CMD $) @@ -179,6 +196,8 @@ set_target_properties (testhdf5_fortran PROPERTIES FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/static ) +add_dependencies (testhdf5_fortran ${HDF5_F90_TEST_LIB_TARGET}) + if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) add_executable (testhdf5_fortran-shared fortranlib_test.F90 @@ -213,6 +232,7 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/shared ) + add_dependencies (testhdf5_fortran-shared ${HDF5_F90_TEST_LIBSH_TARGET}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) #-- Adding test for testhdf5_fortran_1_8 @@ -240,6 +260,8 @@ set_target_properties (testhdf5_fortran_1_8 PROPERTIES FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/static ) +add_dependencies (testhdf5_fortran_1_8 ${HDF5_F90_TEST_LIB_TARGET}) + if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) add_executable (testhdf5_fortran_1_8-shared fortranlib_test_1_8.F90 @@ -265,6 +287,7 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/shared ) + add_dependencies (testhdf5_fortran_1_8-shared ${HDF5_F90_TEST_LIBSH_TARGET}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) #-- Adding test for fortranlib_test_F03 @@ -294,6 +317,8 @@ set_target_properties (fortranlib_test_F03 PROPERTIES FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/static ) +add_dependencies (fortranlib_test_F03 ${HDF5_F90_TEST_LIB_TARGET}) + if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) add_executable (fortranlib_test_F03-shared fortranlib_test_F03.F90 @@ -320,7 +345,8 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) LINKER_LANGUAGE Fortran FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/shared -) + ) + add_dependencies (fortranlib_test_F03-shared ${HDF5_F90_TEST_LIBSH_TARGET}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) #-- Adding test for fflush1 @@ -341,8 +367,10 @@ set_target_properties (fflush1 PROPERTIES FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/static ) +add_dependencies (fflush1 ${HDF5_F90_TEST_LIB_TARGET}) + if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) - add_executable (fflush1-shared fflush1.f90) + add_executable (fflush1-shared fflush1.F90) TARGET_NAMING (fflush1-shared SHARED) TARGET_FORTRAN_PROPERTIES (fflush1-shared SHARED " " " ") target_link_libraries (fflush1-shared @@ -359,6 +387,7 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/shared ) + add_dependencies (fflush1-shared ${HDF5_F90_TEST_LIBSH_TARGET}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) #-- Adding test for fflush2 @@ -379,8 +408,10 @@ set_target_properties (fflush2 PROPERTIES FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/static ) +add_dependencies (fflush2 ${HDF5_F90_TEST_LIB_TARGET}) + if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) - add_executable (fflush2-shared fflush2.f90) + add_executable (fflush2-shared fflush2.F90) TARGET_NAMING (fflush2-shared SHARED) TARGET_FORTRAN_PROPERTIES (fflush2-shared SHARED " " " ") target_link_libraries (fflush2-shared @@ -397,6 +428,7 @@ if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) FOLDER test/fortran Fortran_MODULE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/shared ) + add_dependencies (fflush2-shared ${HDF5_F90_TEST_LIBSH_TARGET}) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) include (CMakeTests.cmake) diff --git a/fortran/test/Makefile.am b/fortran/test/Makefile.am index 530ee8c..60f9f53 100644 --- a/fortran/test/Makefile.am +++ b/fortran/test/Makefile.am @@ -43,18 +43,18 @@ check_PROGRAMS=$(TEST_PROG) libh5test_fortran_la_SOURCES = tf_gen.F90 tf.F90 t.c -fortranlib_test_SOURCES = tH5F.f90 tH5D.f90 tH5R.f90 tH5S.f90 tH5T.f90 tH5VL.f90 tH5Z.f90 \ - tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90 tHDF5.f90 fortranlib_test.f90 +fortranlib_test_SOURCES = tH5F.F90 tH5D.F90 tH5R.F90 tH5S.F90 tH5T.F90 tH5VL.F90 tH5Z.F90 \ + tH5Sselect.F90 tH5P.F90 tH5A.F90 tH5I.F90 tH5G.F90 tH5E.F90 tHDF5.F90 fortranlib_test.F90 -fortranlib_test_1_8_SOURCES = tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90 tH5MISC_1_8.f90 tHDF5_1_8.f90 \ - fortranlib_test_1_8.f90 +fortranlib_test_1_8_SOURCES = tH5O.F90 tH5A_1_8.F90 tH5G_1_8.F90 tH5MISC_1_8.F90 tHDF5_1_8.F90 \ + fortranlib_test_1_8.F90 -fortranlib_test_F03_SOURCES = tH5E_F03.f90 tH5F_F03.f90 tH5L_F03.f90 \ - tH5O_F03.f90 tH5P_F03.f90 tH5T_F03.F90 tHDF5_F03.f90 fortranlib_test_F03.f90 +fortranlib_test_F03_SOURCES = tH5E_F03.F90 tH5F_F03.F90 tH5L_F03.F90 \ + tH5O_F03.F90 tH5P_F03.F90 tH5T_F03.F90 tHDF5_F03.F90 fortranlib_test_F03.F90 -fflush1_SOURCES=fflush1.f90 -fflush2_SOURCES=fflush2.f90 +fflush1_SOURCES=fflush1.F90 +fflush2_SOURCES=fflush2.F90 # The tests depend on both fortran libraries and both main libraries. LDADD=libh5test_fortran.la $(LIBH5TEST) $(LIBH5F) $(LIBHDF5) diff --git a/fortran/test/Makefile.in b/fortran/test/Makefile.in index 8352da8..38aacf2 100644 --- a/fortran/test/Makefile.in +++ b/fortran/test/Makefile.in @@ -202,13 +202,6 @@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = -FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS) -LTFCCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=FC $(AM_LIBTOOLFLAGS) \ - $(LIBTOOLFLAGS) --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS) -AM_V_FC = $(am__v_FC_@AM_V@) -am__v_FC_ = $(am__v_FC_@AM_DEFAULT_V@) -am__v_FC_0 = @echo " FC " $@; -am__v_FC_1 = SOURCES = $(libh5test_fortran_la_SOURCES) \ $(H5_test_buildiface_SOURCES) $(fflush1_SOURCES) \ $(fflush2_SOURCES) $(fortranlib_test_SOURCES) \ @@ -517,6 +510,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ @@ -739,17 +733,17 @@ noinst_LTLIBRARIES = libh5test_fortran.la # Our main targets, the tests themselves TEST_PROG = fortranlib_test fflush1 fflush2 fortranlib_test_1_8 fortranlib_test_F03 libh5test_fortran_la_SOURCES = tf_gen.F90 tf.F90 t.c -fortranlib_test_SOURCES = tH5F.f90 tH5D.f90 tH5R.f90 tH5S.f90 tH5T.f90 tH5VL.f90 tH5Z.f90 \ - tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90 tHDF5.f90 fortranlib_test.f90 +fortranlib_test_SOURCES = tH5F.F90 tH5D.F90 tH5R.F90 tH5S.F90 tH5T.F90 tH5VL.F90 tH5Z.F90 \ + tH5Sselect.F90 tH5P.F90 tH5A.F90 tH5I.F90 tH5G.F90 tH5E.F90 tHDF5.F90 fortranlib_test.F90 -fortranlib_test_1_8_SOURCES = tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90 tH5MISC_1_8.f90 tHDF5_1_8.f90 \ - fortranlib_test_1_8.f90 +fortranlib_test_1_8_SOURCES = tH5O.F90 tH5A_1_8.F90 tH5G_1_8.F90 tH5MISC_1_8.F90 tHDF5_1_8.F90 \ + fortranlib_test_1_8.F90 -fortranlib_test_F03_SOURCES = tH5E_F03.f90 tH5F_F03.f90 tH5L_F03.f90 \ - tH5O_F03.f90 tH5P_F03.f90 tH5T_F03.F90 tHDF5_F03.f90 fortranlib_test_F03.f90 +fortranlib_test_F03_SOURCES = tH5E_F03.F90 tH5F_F03.F90 tH5L_F03.F90 \ + tH5O_F03.F90 tH5P_F03.F90 tH5T_F03.F90 tHDF5_F03.F90 fortranlib_test_F03.F90 -fflush1_SOURCES = fflush1.f90 -fflush2_SOURCES = fflush2.f90 +fflush1_SOURCES = fflush1.F90 +fflush2_SOURCES = fflush2.F90 # The tests depend on both fortran libraries and both main libraries. LDADD = libh5test_fortran.la $(LIBH5TEST) $(LIBH5F) $(LIBHDF5) @@ -915,12 +909,6 @@ distclean-compile: @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $< -.f90.obj: - $(AM_V_FC)$(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) `$(CYGPATH_W) '$<'` - -.f90.lo: - $(AM_V_FC)$(LTFCCOMPILE) -c -o $@ $(FCFLAGS_f90) $< - mostlyclean-libtool: -rm -f *.lo diff --git a/fortran/test/fflush1.F90 b/fortran/test/fflush1.F90 new file mode 100644 index 0000000..ca2550f --- /dev/null +++ b/fortran/test/fflush1.F90 @@ -0,0 +1,157 @@ +!****h* root/fortran/test/fflush1.f90 +! +! NAME +! FFLUSH1EXAMPLE +! +! FUNCTION +! This is the first half of a two-part test that makes sure +! that a file can be read after an application crashes as long +! as the file was flushed first. We simulate by exit the +! the program using stop statement +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + + PROGRAM FFLUSH1EXAMPLE + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + + ! + !the respective filename is "fflush1.h5" + ! + CHARACTER(LEN=7), PARAMETER :: filename = "fflush1" + CHARACTER(LEN=80) :: fix_filename + + ! + !data space rank and dimensions + ! + INTEGER, PARAMETER :: RANK = 2 + INTEGER, PARAMETER :: NX = 4 + INTEGER, PARAMETER :: NY = 5 + + ! + ! File identifiers + ! + INTEGER(HID_T) :: file_id + + ! + ! Group identifier + ! + INTEGER(HID_T) :: gid + + ! + ! dataset identifier + ! + INTEGER(HID_T) :: dset_id + + ! + ! 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, total_error = 0 + + ! + !data buffers + ! + INTEGER, DIMENSION(NX,NY) :: data_in + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + data_dims(1) = NX + data_dims(2) = NY + + ! + !Initialize FORTRAN predifined datatypes + ! + CALL h5open_f(error) + CALL check("h5open_f",error,total_error) + + ! + !Initialize data_in buffer + ! + do i = 1, NX + do j = 1, NY + data_in(i,j) = (i-1) + (j-1) + end do + end do + + ! + !Create file "fflush1.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 "/G" inside file "fflush1.h5". + ! + CALL h5gcreate_f(file_id, "/G", gid, error) + CALL check("h5gcreate_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 "fflush1.h5". + ! + CALL h5dcreate_f(file_id, "/D", H5T_NATIVE_INTEGER, dataspace, & + dset_id, error) + CALL check("h5dcreate_f",error,total_error) + + ! + ! Write data_in to the dataset + ! + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data_in, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + + ! + !flush and exit without closing the library + ! + CALL H5fflush_f(file_id, H5F_SCOPE_GLOBAL_F, error) + CALL check("h5fflush_f",error,total_error) + + ! if errors detected, exit with non-zero code. + IF (total_error .ne. 0) CALL h5_exit_f (1) + + + STOP + + + END PROGRAM FFLUSH1EXAMPLE + diff --git a/fortran/test/fflush1.f90 b/fortran/test/fflush1.f90 deleted file mode 100644 index ca2550f..0000000 --- a/fortran/test/fflush1.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!****h* root/fortran/test/fflush1.f90 -! -! NAME -! FFLUSH1EXAMPLE -! -! FUNCTION -! This is the first half of a two-part test that makes sure -! that a file can be read after an application crashes as long -! as the file was flushed first. We simulate by exit the -! the program using stop statement -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - - PROGRAM FFLUSH1EXAMPLE - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - - ! - !the respective filename is "fflush1.h5" - ! - CHARACTER(LEN=7), PARAMETER :: filename = "fflush1" - CHARACTER(LEN=80) :: fix_filename - - ! - !data space rank and dimensions - ! - INTEGER, PARAMETER :: RANK = 2 - INTEGER, PARAMETER :: NX = 4 - INTEGER, PARAMETER :: NY = 5 - - ! - ! File identifiers - ! - INTEGER(HID_T) :: file_id - - ! - ! Group identifier - ! - INTEGER(HID_T) :: gid - - ! - ! dataset identifier - ! - INTEGER(HID_T) :: dset_id - - ! - ! 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, total_error = 0 - - ! - !data buffers - ! - INTEGER, DIMENSION(NX,NY) :: data_in - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - data_dims(1) = NX - data_dims(2) = NY - - ! - !Initialize FORTRAN predifined datatypes - ! - CALL h5open_f(error) - CALL check("h5open_f",error,total_error) - - ! - !Initialize data_in buffer - ! - do i = 1, NX - do j = 1, NY - data_in(i,j) = (i-1) + (j-1) - end do - end do - - ! - !Create file "fflush1.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 "/G" inside file "fflush1.h5". - ! - CALL h5gcreate_f(file_id, "/G", gid, error) - CALL check("h5gcreate_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 "fflush1.h5". - ! - CALL h5dcreate_f(file_id, "/D", H5T_NATIVE_INTEGER, dataspace, & - dset_id, error) - CALL check("h5dcreate_f",error,total_error) - - ! - ! Write data_in to the dataset - ! - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data_in, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - - ! - !flush and exit without closing the library - ! - CALL H5fflush_f(file_id, H5F_SCOPE_GLOBAL_F, error) - CALL check("h5fflush_f",error,total_error) - - ! if errors detected, exit with non-zero code. - IF (total_error .ne. 0) CALL h5_exit_f (1) - - - STOP - - - END PROGRAM FFLUSH1EXAMPLE - diff --git a/fortran/test/fflush2.F90 b/fortran/test/fflush2.F90 new file mode 100644 index 0000000..4230832 --- /dev/null +++ b/fortran/test/fflush2.F90 @@ -0,0 +1,177 @@ +!****h* root/fortran/test/fflush2.f90 +! +! NAME +! fflush2.f90 +! +! FUNCTION +! This is the second half of a two-part test that makes sure +! that a file can be read after an application crashes as long +! as the file was flushed first. This half tries to read the +! file created by the first half. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +PROGRAM FFLUSH2EXAMPLE + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + + CHARACTER(LEN=7), PARAMETER :: filename = "fflush1" + CHARACTER(LEN=80) :: fix_filename + + ! + !data space rank and dimensions + ! + INTEGER, PARAMETER :: NX = 4 + INTEGER, PARAMETER :: NY = 5 + + ! + ! File identifiers + ! + INTEGER(HID_T) :: file_id + + ! + ! Group identifier + ! + INTEGER(HID_T) :: gid + + ! + ! dataset identifier + ! + INTEGER(HID_T) :: dset_id + + + ! + ! data type identifier + ! + INTEGER(HID_T) :: dtype_id + + ! + !flag to check operation success + ! + INTEGER :: error + + ! + !general purpose integer + ! + INTEGER :: i, j, total_error = 0 + + ! + !data buffers + ! + INTEGER, DIMENSION(NX,NY) :: data_out + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + data_dims(1) = NX + data_dims(2) = NY + + ! + !Initialize FORTRAN predifined datatypes + ! + CALL h5open_f(error) + CALL check("h5open_f",error,total_error) + + ! + !Open the 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 h5fopen_f(fix_filename, H5F_ACC_RDONLY_F, file_id, error) + CALL check("h5fopen_f",error,total_error) + + ! + !Open the dataset + ! + CALL h5dopen_f(file_id, "/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) + + ! + !Print the dataset. + ! + DO i = 1, NX + WRITE(*,*) (data_out(i,j), j = 1, NY) + END DO + ! + !result of the print statement + ! + ! 0, 1, 2, 3, 4 + ! 1, 2, 3, 4, 5 + ! 2, 3, 4, 5, 6 + ! 3, 4, 5, 6, 7 + + ! + !Open the group. + ! + CALL h5gopen_f(file_id, "G", gid, error) + CALL check("h5gopen_f",error,total_error) + + ! + !In case error happens, exit. + ! + IF (error == -1) CALL h5_exit_f (1) + ! + !Close the datatype + ! + CALL h5tclose_f(dtype_id, error) + CALL check("h5tclose_f",error,total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + + ! + !Close the group. + ! + CALL h5gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + + ! + !Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + + ! + !Close FORTRAN predifined datatypes + ! + CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL h5close_f(error) + CALL check("h5close_types_f",error,total_error) + + ! if errors detected, exit with non-zero code. + IF (total_error .ne. 0) CALL h5_exit_f (1) + +END PROGRAM FFLUSH2EXAMPLE diff --git a/fortran/test/fflush2.f90 b/fortran/test/fflush2.f90 deleted file mode 100644 index 4230832..0000000 --- a/fortran/test/fflush2.f90 +++ /dev/null @@ -1,177 +0,0 @@ -!****h* root/fortran/test/fflush2.f90 -! -! NAME -! fflush2.f90 -! -! FUNCTION -! This is the second half of a two-part test that makes sure -! that a file can be read after an application crashes as long -! as the file was flushed first. This half tries to read the -! file created by the first half. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -PROGRAM FFLUSH2EXAMPLE - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - - CHARACTER(LEN=7), PARAMETER :: filename = "fflush1" - CHARACTER(LEN=80) :: fix_filename - - ! - !data space rank and dimensions - ! - INTEGER, PARAMETER :: NX = 4 - INTEGER, PARAMETER :: NY = 5 - - ! - ! File identifiers - ! - INTEGER(HID_T) :: file_id - - ! - ! Group identifier - ! - INTEGER(HID_T) :: gid - - ! - ! dataset identifier - ! - INTEGER(HID_T) :: dset_id - - - ! - ! data type identifier - ! - INTEGER(HID_T) :: dtype_id - - ! - !flag to check operation success - ! - INTEGER :: error - - ! - !general purpose integer - ! - INTEGER :: i, j, total_error = 0 - - ! - !data buffers - ! - INTEGER, DIMENSION(NX,NY) :: data_out - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - data_dims(1) = NX - data_dims(2) = NY - - ! - !Initialize FORTRAN predifined datatypes - ! - CALL h5open_f(error) - CALL check("h5open_f",error,total_error) - - ! - !Open the 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 h5fopen_f(fix_filename, H5F_ACC_RDONLY_F, file_id, error) - CALL check("h5fopen_f",error,total_error) - - ! - !Open the dataset - ! - CALL h5dopen_f(file_id, "/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) - - ! - !Print the dataset. - ! - DO i = 1, NX - WRITE(*,*) (data_out(i,j), j = 1, NY) - END DO - ! - !result of the print statement - ! - ! 0, 1, 2, 3, 4 - ! 1, 2, 3, 4, 5 - ! 2, 3, 4, 5, 6 - ! 3, 4, 5, 6, 7 - - ! - !Open the group. - ! - CALL h5gopen_f(file_id, "G", gid, error) - CALL check("h5gopen_f",error,total_error) - - ! - !In case error happens, exit. - ! - IF (error == -1) CALL h5_exit_f (1) - ! - !Close the datatype - ! - CALL h5tclose_f(dtype_id, error) - CALL check("h5tclose_f",error,total_error) - - ! - !Close the dataset. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - - ! - !Close the group. - ! - CALL h5gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - - ! - !Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - - ! - !Close FORTRAN predifined datatypes - ! - CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL h5close_f(error) - CALL check("h5close_types_f",error,total_error) - - ! if errors detected, exit with non-zero code. - IF (total_error .ne. 0) CALL h5_exit_f (1) - -END PROGRAM FFLUSH2EXAMPLE diff --git a/fortran/test/fortranlib_test.F90 b/fortran/test/fortranlib_test.F90 new file mode 100644 index 0000000..2f88c45 --- /dev/null +++ b/fortran/test/fortranlib_test.F90 @@ -0,0 +1,257 @@ +!****h* root/fortran/test/fortranlib_test.f90 +! +! NAME +! fortranlib_test.f90 +! +! FUNCTION +! Basic testing of Fortran API's functionality. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +!#include + +PROGRAM fortranlibtest + + USE HDF5 + USE THDF5 + + IMPLICIT NONE + INTEGER :: total_error = 0 + INTEGER :: error + INTEGER :: majnum, minnum, relnum + LOGICAL :: szip_flag + INTEGER :: ret_total_error + LOGICAL :: cleanup, status + + CALL h5open_f(error) + + cleanup = .TRUE. + CALL h5_env_nocleanup_f(status) + IF(status) cleanup=.FALSE. + + WRITE(*,*) ' ========================== ' + WRITE(*,*) ' FORTRAN tests ' + WRITE(*,*) ' ========================== ' + CALL h5get_libversion_f(majnum, minnum, relnum, total_error) + IF(total_error .EQ. 0) THEN + + WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") + WRITE(*, '(I1)', advance="NO") majnum + WRITE(*, '(".")', advance="NO") + WRITE(*, '(I1)', advance="NO") minnum + WRITE(*, '(" release ")', advance="NO") + WRITE(*, '(I3)') relnum + ELSE + total_error = total_error + 1 + ENDIF + WRITE(*,*) + +! CALL h5check_version_f(1,4,4,total_error) +! write(*,*) '=========================================' +! write(*,*) 'Testing FILE Interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL mountingtest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Mounting test', total_error) + + ret_total_error = 0 + CALL reopentest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Reopen test', total_error) + + ret_total_error = 0 + CALL file_close(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' File open/close test', total_error) + + ret_total_error = 0 + CALL file_space("file_space",cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' File free space test', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing DATASET Interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL datasettest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Dataset test', total_error) + + ret_total_error = 0 + CALL extenddsettest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Extendible dataset test', total_error) + +! -- DISABLE TEST FOR PGI COMPILER DUE TO COMPILER BUG -- 8/2015 -- HDFFV-9498 +!#if H5_Fortran_COMPILER_ID!=PGI +! CALL test_userblock_offset(cleanup, ret_total_error) +! CALL write_test_status(ret_total_error, ' Dataset offset with user block', total_error) +!#endif + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing DATASPACE Interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL dataspace_basic_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Basic dataspace test', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing REFERENCE Interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL refobjtest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Reference to object test', total_error) + + ret_total_error = 0 + CALL refregtest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Reference to dataset region test', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing selection functionalities ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL test_basic_select(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Basic selection test', total_error) + + + ret_total_error = 0 + CALL test_select_hyperslab( cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Hyperslab selection test', total_error) + + ret_total_error = 0 + CALL test_select_element(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Element selection test', total_error) + + ret_total_error = 0 + CALL test_select_point(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Element selection functions test ', total_error) + + ret_total_error = 0 + CALL test_select_combine(ret_total_error) + CALL write_test_status(ret_total_error, ' Selection combinations test ', total_error) + + ret_total_error = 0 + CALL test_select_bounds(ret_total_error) + CALL write_test_status(ret_total_error, ' Selection bounds test ', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing DATATYPE interface ' +! write(*,*) '=========================================' + ret_total_error = 0 + CALL basic_data_type_test(ret_total_error) + CALL write_test_status(ret_total_error, ' Basic datatype test', total_error) + + ret_total_error = 0 + CALL compoundtest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Compound datatype test', total_error) + + ret_total_error = 0 + CALL enumtest(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Enum datatype test', total_error) + + ret_total_error = 0 + CALL test_derived_flt(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Derived float datatype test', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing PROPERTY interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL external_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' External dataset test', total_error) + + ret_total_error = 0 + CALL multi_file_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Multi file driver test', total_error) + + ret_total_error = 0 + CALL test_chunk_cache (cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Dataset chunk cache configuration', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing ATTRIBUTE interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL attribute_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Attribute test', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing IDENTIFIER interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL identifier_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Identifier test', total_error) + + ret_total_error = 0 + CALL filters_test(ret_total_error) + CALL write_test_status(ret_total_error, ' Filters test', total_error) + + ret_total_error = 0 + CALL szip_test(szip_flag, cleanup, ret_total_error) + + IF (.NOT. szip_flag) THEN ! test not available + CALL write_test_status(-1, ' SZIP filter test', total_error) + ELSE + CALL write_test_status(ret_total_error, ' SZIP filter test', total_error) + ENDIF + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing GROUP interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL group_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Group test', total_error) + + ret_total_error = 0 + CALL error_report_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Error test', total_error) + + ret_total_error = 0 + CALL vl_test_integer(cleanup, ret_total_error) + CALL vl_test_real(cleanup, ret_total_error) + CALL vl_test_string(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' VL test', total_error) + + WRITE(*,*) + + WRITE(*,*) ' ============================================ ' + WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' + WRITE(*, fmt = '(i4)', advance='NO') total_error + WRITE(*, fmt = '(12a)' ) ' error(s) ! ' + WRITE(*,*) ' ============================================ ' + + CALL h5close_f(error) + + ! if errors detected, exit with non-zero code. + IF (total_error .NE. 0) CALL h5_exit_f (1) + +END PROGRAM fortranlibtest diff --git a/fortran/test/fortranlib_test.f90 b/fortran/test/fortranlib_test.f90 deleted file mode 100644 index f41d811..0000000 --- a/fortran/test/fortranlib_test.f90 +++ /dev/null @@ -1,252 +0,0 @@ -!****h* root/fortran/test/fortranlib_test.f90 -! -! NAME -! fortranlib_test.f90 -! -! FUNCTION -! Basic testing of Fortran API's functionality. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -PROGRAM fortranlibtest - - USE HDF5 - USE THDF5 - - IMPLICIT NONE - INTEGER :: total_error = 0 - INTEGER :: error - INTEGER :: majnum, minnum, relnum - LOGICAL :: szip_flag - INTEGER :: ret_total_error - LOGICAL :: cleanup, status - - CALL h5open_f(error) - - cleanup = .TRUE. - CALL h5_env_nocleanup_f(status) - IF(status) cleanup=.FALSE. - - WRITE(*,*) ' ========================== ' - WRITE(*,*) ' FORTRAN tests ' - WRITE(*,*) ' ========================== ' - CALL h5get_libversion_f(majnum, minnum, relnum, total_error) - IF(total_error .EQ. 0) THEN - - WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") - WRITE(*, '(I1)', advance="NO") majnum - WRITE(*, '(".")', advance="NO") - WRITE(*, '(I1)', advance="NO") minnum - WRITE(*, '(" release ")', advance="NO") - WRITE(*, '(I3)') relnum - ELSE - total_error = total_error + 1 - ENDIF - WRITE(*,*) - -! CALL h5check_version_f(1,4,4,total_error) -! write(*,*) '=========================================' -! write(*,*) 'Testing FILE Interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL mountingtest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Mounting test', total_error) - - ret_total_error = 0 - CALL reopentest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Reopen test', total_error) - - ret_total_error = 0 - CALL file_close(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' File open/close test', total_error) - - ret_total_error = 0 - CALL file_space("file_space",cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' File free space test', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing DATASET Interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL datasettest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Dataset test', total_error) - - ret_total_error = 0 - CALL extenddsettest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Extendible dataset test', total_error) -! MSB--DISABLED TEST-- Fails for unknown reasons on platypus with pgf90 compiler -! CALL test_userblock_offset(cleanup, ret_total_error) -! CALL write_test_status(ret_total_error, ' Dataset offset with user block', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing DATASPACE Interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL dataspace_basic_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Basic dataspace test', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing REFERENCE Interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL refobjtest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Reference to object test', total_error) - - ret_total_error = 0 - CALL refregtest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Reference to dataset region test', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing selection functionalities ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL test_basic_select(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Basic selection test', total_error) - - - ret_total_error = 0 - CALL test_select_hyperslab( cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Hyperslab selection test', total_error) - - ret_total_error = 0 - CALL test_select_element(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Element selection test', total_error) - - ret_total_error = 0 - CALL test_select_point(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Element selection functions test ', total_error) - - ret_total_error = 0 - CALL test_select_combine(ret_total_error) - CALL write_test_status(ret_total_error, ' Selection combinations test ', total_error) - - ret_total_error = 0 - CALL test_select_bounds(ret_total_error) - CALL write_test_status(ret_total_error, ' Selection bounds test ', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing DATATYPE interface ' -! write(*,*) '=========================================' - ret_total_error = 0 - CALL basic_data_type_test(ret_total_error) - CALL write_test_status(ret_total_error, ' Basic datatype test', total_error) - - ret_total_error = 0 - CALL compoundtest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Compound datatype test', total_error) - - ret_total_error = 0 - CALL enumtest(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Enum datatype test', total_error) - - ret_total_error = 0 - CALL test_derived_flt(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Derived float datatype test', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing PROPERTY interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL external_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' External dataset test', total_error) - - ret_total_error = 0 - CALL multi_file_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Multi file driver test', total_error) - - ret_total_error = 0 - CALL test_chunk_cache (cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Dataset chunk cache configuration', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing ATTRIBUTE interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL attribute_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Attribute test', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing IDENTIFIER interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL identifier_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Identifier test', total_error) - - ret_total_error = 0 - CALL filters_test(ret_total_error) - CALL write_test_status(ret_total_error, ' Filters test', total_error) - - ret_total_error = 0 - CALL szip_test(szip_flag, cleanup, ret_total_error) - - IF (.NOT. szip_flag) THEN ! test not available - CALL write_test_status(-1, ' SZIP filter test', total_error) - ELSE - CALL write_test_status(ret_total_error, ' SZIP filter test', total_error) - ENDIF - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing GROUP interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL group_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Group test', total_error) - - ret_total_error = 0 - CALL error_report_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Error test', total_error) - - ret_total_error = 0 - CALL vl_test_integer(cleanup, ret_total_error) - CALL vl_test_real(cleanup, ret_total_error) - CALL vl_test_string(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' VL test', total_error) - - WRITE(*,*) - - WRITE(*,*) ' ============================================ ' - WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' - WRITE(*, fmt = '(i4)', advance='NO') total_error - WRITE(*, fmt = '(12a)' ) ' error(s) ! ' - WRITE(*,*) ' ============================================ ' - - CALL h5close_f(error) - - ! if errors detected, exit with non-zero code. - IF (total_error .NE. 0) CALL h5_exit_f (1) - -END PROGRAM fortranlibtest diff --git a/fortran/test/fortranlib_test_1_8.F90 b/fortran/test/fortranlib_test_1_8.F90 new file mode 100644 index 0000000..320d661 --- /dev/null +++ b/fortran/test/fortranlib_test_1_8.F90 @@ -0,0 +1,122 @@ +!****h* root/fortran/test/fortranlib_test_1_8.f90 +! +! NAME +! fortranlib_test_1_8.f90 +! +! FUNCTION +! Basic testing of Fortran API's introduced in 1.8 release. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +PROGRAM fortranlibtest + + USE HDF5 + USE THDF5_1_8 + USE TH5_MISC + IMPLICIT NONE + INTEGER :: total_error = 0 + INTEGER :: error + INTEGER :: ret_total_error + INTEGER :: majnum, minnum, relnum + LOGICAL :: cleanup, status + + CALL h5open_f(error) + + cleanup = .TRUE. + CALL h5_env_nocleanup_f(status) + IF(status) cleanup=.FALSE. + + WRITE(*,*) ' ========================== ' + WRITE(*,*) ' FORTRAN 1.8 tests ' + WRITE(*,*) ' ========================== ' + CALL h5get_libversion_f(majnum, minnum, relnum, total_error) + IF(total_error .EQ. 0) THEN + WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") + WRITE(*, '(I1)', advance="NO") majnum + WRITE(*, '(".")', advance="NO") + WRITE(*, '(I1)', advance="NO") minnum + WRITE(*, '(" release ")', advance="NO") + WRITE(*, '(I3)') relnum + ELSE + total_error = total_error + 1 + ENDIF + WRITE(*,*) + + CALL h5eset_auto_f(0, ret_total_error) + IF(ret_total_error.NE.0) & + CALL write_test_status(ret_total_error, & + ' h5eset_auto_f', & + total_error) + + ret_total_error = 0 + CALL attribute_test_1_8(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing attributes', & + total_error) + + ret_total_error = 0 + CALL group_test(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing groups', & + total_error) + + ret_total_error = 0 + CALL test_h5o(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing object interface', & + total_error) + + ret_total_error = 0 + CALL dtransform(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing data transform', & + total_error) + + ret_total_error = 0 + CALL test_h5s_encode(ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing dataspace encoding and decoding', & + total_error) + + ret_total_error = 0 + CALL test_scaleoffset(cleanup, ret_total_error ) + CALL write_test_status(ret_total_error, & + ' Testing scaleoffset filter', & + total_error) + + ret_total_error = 0 + CALL test_genprop_basic_class(ret_total_error ) + CALL write_test_status(ret_total_error, & + ' Testing basic generic property list class creation functionality', & + total_error) + + WRITE(*,*) + + WRITE(*,*) ' ============================================ ' + WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' + WRITE(*, fmt = '(i4)', advance='NO') total_error + WRITE(*, fmt = '(12a)' ) ' error(s) ! ' + WRITE(*,*) ' ============================================ ' + + CALL h5close_f(error) + + ! if errors detected, exit with non-zero code. + IF (total_error .NE. 0) CALL h5_exit_f (1) + +END PROGRAM fortranlibtest diff --git a/fortran/test/fortranlib_test_1_8.f90 b/fortran/test/fortranlib_test_1_8.f90 deleted file mode 100644 index 320d661..0000000 --- a/fortran/test/fortranlib_test_1_8.f90 +++ /dev/null @@ -1,122 +0,0 @@ -!****h* root/fortran/test/fortranlib_test_1_8.f90 -! -! NAME -! fortranlib_test_1_8.f90 -! -! FUNCTION -! Basic testing of Fortran API's introduced in 1.8 release. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -PROGRAM fortranlibtest - - USE HDF5 - USE THDF5_1_8 - USE TH5_MISC - IMPLICIT NONE - INTEGER :: total_error = 0 - INTEGER :: error - INTEGER :: ret_total_error - INTEGER :: majnum, minnum, relnum - LOGICAL :: cleanup, status - - CALL h5open_f(error) - - cleanup = .TRUE. - CALL h5_env_nocleanup_f(status) - IF(status) cleanup=.FALSE. - - WRITE(*,*) ' ========================== ' - WRITE(*,*) ' FORTRAN 1.8 tests ' - WRITE(*,*) ' ========================== ' - CALL h5get_libversion_f(majnum, minnum, relnum, total_error) - IF(total_error .EQ. 0) THEN - WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") - WRITE(*, '(I1)', advance="NO") majnum - WRITE(*, '(".")', advance="NO") - WRITE(*, '(I1)', advance="NO") minnum - WRITE(*, '(" release ")', advance="NO") - WRITE(*, '(I3)') relnum - ELSE - total_error = total_error + 1 - ENDIF - WRITE(*,*) - - CALL h5eset_auto_f(0, ret_total_error) - IF(ret_total_error.NE.0) & - CALL write_test_status(ret_total_error, & - ' h5eset_auto_f', & - total_error) - - ret_total_error = 0 - CALL attribute_test_1_8(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing attributes', & - total_error) - - ret_total_error = 0 - CALL group_test(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing groups', & - total_error) - - ret_total_error = 0 - CALL test_h5o(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing object interface', & - total_error) - - ret_total_error = 0 - CALL dtransform(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing data transform', & - total_error) - - ret_total_error = 0 - CALL test_h5s_encode(ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing dataspace encoding and decoding', & - total_error) - - ret_total_error = 0 - CALL test_scaleoffset(cleanup, ret_total_error ) - CALL write_test_status(ret_total_error, & - ' Testing scaleoffset filter', & - total_error) - - ret_total_error = 0 - CALL test_genprop_basic_class(ret_total_error ) - CALL write_test_status(ret_total_error, & - ' Testing basic generic property list class creation functionality', & - total_error) - - WRITE(*,*) - - WRITE(*,*) ' ============================================ ' - WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' - WRITE(*, fmt = '(i4)', advance='NO') total_error - WRITE(*, fmt = '(12a)' ) ' error(s) ! ' - WRITE(*,*) ' ============================================ ' - - CALL h5close_f(error) - - ! if errors detected, exit with non-zero code. - IF (total_error .NE. 0) CALL h5_exit_f (1) - -END PROGRAM fortranlibtest diff --git a/fortran/test/fortranlib_test_F03.F90 b/fortran/test/fortranlib_test_F03.F90 new file mode 100644 index 0000000..5b386b9 --- /dev/null +++ b/fortran/test/fortranlib_test_F03.F90 @@ -0,0 +1,193 @@ +!****h* root/fortran/test/fortranlib_test_F03.f90 +! +! NAME +! fortranlib_test_F03.f90 +! +! FUNCTION +! Basic testing of Fortran API's requiring Fortran 2003 +! compliance. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +PROGRAM fortranlibtest_F03 + + USE HDF5 + USE THDF5_F03 + + IMPLICIT NONE + INTEGER :: total_error = 0 + INTEGER :: error + INTEGER :: majnum, minnum, relnum + INTEGER :: ret_total_error + LOGICAL :: cleanup, status + + CALL h5open_f(error) + + cleanup = .TRUE. + CALL h5_env_nocleanup_f(status) + IF(status) cleanup=.FALSE. + + WRITE(*,'(24X,A)') '==============================' + WRITE(*,'(24X,A)') ' FORTRAN 2003 tests ' + WRITE(*,'(24X,A)') '==============================' + CALL h5get_libversion_f(majnum, minnum, relnum, total_error) + IF(total_error .EQ. 0) THEN + WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") + WRITE(*, '(I1)', advance="NO") majnum + WRITE(*, '(".")', advance="NO") + WRITE(*, '(I1)', advance="NO") minnum + WRITE(*, '(" release ")', advance="NO") + WRITE(*, '(I3)') relnum + ELSE + total_error = total_error + 1 + ENDIF + + ret_total_error = 0 +! PROBLEMS with C +! CALL test_error(ret_total_error) +! CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error) + + WRITE(*,*) + + ret_total_error = 0 + CALL test_array_compound_atomic(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Datatypes Functionality', total_error) + + ret_total_error = 0 + CALL test_array_compound_array(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Array Datatypes Functionality', total_error) + + ret_total_error = 0 + CALL t_array(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing 3-D array by dataset, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_enum(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading enum dataset, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_enum_conv(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing enumeration conversions', total_error) + + ret_total_error = 0 + CALL t_bit(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading bitfield dataset, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_opaque(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading opaque datatypes, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_objref(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading object references, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_regref(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading region references, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_vlen(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading variable-length datatypes, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_vlstring(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading variable-string datatypes, using C_LOC', total_error) + + ret_total_error = 0 + CALL t_vlstring_readwrite(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing variable-string write/read, using h5dwrite_f/h5dread_f', total_error) + + ret_total_error = 0 + CALL t_string(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing writing/reading string datatypes, using C_LOC', total_error) + + ret_total_error = 0 + CALL vl_test_special_char(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing string datatypes containing control characters', total_error) + + ret_total_error = 0 + CALL test_create(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing filling functions', total_error) + + ret_total_error = 0 + CALL test_h5kind_to_type(total_error) + CALL write_test_status(ret_total_error, ' Test function h5kind_to_type', total_error) + + ret_total_error = 0 + CALL test_array_bkg(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing Partial I/O of Array Fields in Compound Datatype FunctionalityT', total_error) + + ret_total_error = 0 + CALL test_genprop_class_callback(ret_total_error) + CALL write_test_status(ret_total_error, ' Test basic generic property list callback functionality', total_error) + + ret_total_error = 0 + CALL test_iter_group(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing group iteration functionality', total_error) + + ret_total_error = 0 + CALL test_nbit(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing nbit filter', total_error) + + ret_total_error = 0 + CALL external_test_offset(cleanup, ret_total_error) + CALL write_test_status(ret_total_error, ' Testing external dataset with offset', total_error) + + ret_total_error = 0 + CALL test_h5p_file_image(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing h5pset/get file image', total_error) + +! write(*,*) +! write(*,*) '=========================================' +! write(*,*) 'Testing GROUP interface ' +! write(*,*) '=========================================' + + ret_total_error = 0 + CALL test_h5o_refcount(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing object functions ', total_error) + + ret_total_error = 0 + CALL obj_visit(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing object visiting functions ', total_error) + + ret_total_error = 0 + CALL obj_info(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing object info functions ', total_error) + + ret_total_error = 0 + CALL test_get_file_image(ret_total_error) + CALL write_test_status(ret_total_error, ' Testing get file image ', total_error) + + + WRITE(*,*) + + WRITE(*,*) ' ============================================ ' + WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' + WRITE(*, fmt = '(i4)', advance='NO') total_error + WRITE(*, fmt = '(12a)' ) ' error(s) ! ' + WRITE(*,*) ' ============================================ ' + + CALL h5close_f(error) + + ! if errors detected, exit with non-zero code. + IF (total_error .NE. 0) CALL h5_exit_f(1) + +END PROGRAM fortranlibtest_F03 + + diff --git a/fortran/test/fortranlib_test_F03.f90 b/fortran/test/fortranlib_test_F03.f90 deleted file mode 100644 index 5b386b9..0000000 --- a/fortran/test/fortranlib_test_F03.f90 +++ /dev/null @@ -1,193 +0,0 @@ -!****h* root/fortran/test/fortranlib_test_F03.f90 -! -! NAME -! fortranlib_test_F03.f90 -! -! FUNCTION -! Basic testing of Fortran API's requiring Fortran 2003 -! compliance. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -PROGRAM fortranlibtest_F03 - - USE HDF5 - USE THDF5_F03 - - IMPLICIT NONE - INTEGER :: total_error = 0 - INTEGER :: error - INTEGER :: majnum, minnum, relnum - INTEGER :: ret_total_error - LOGICAL :: cleanup, status - - CALL h5open_f(error) - - cleanup = .TRUE. - CALL h5_env_nocleanup_f(status) - IF(status) cleanup=.FALSE. - - WRITE(*,'(24X,A)') '==============================' - WRITE(*,'(24X,A)') ' FORTRAN 2003 tests ' - WRITE(*,'(24X,A)') '==============================' - CALL h5get_libversion_f(majnum, minnum, relnum, total_error) - IF(total_error .EQ. 0) THEN - WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO") - WRITE(*, '(I1)', advance="NO") majnum - WRITE(*, '(".")', advance="NO") - WRITE(*, '(I1)', advance="NO") minnum - WRITE(*, '(" release ")', advance="NO") - WRITE(*, '(I3)') relnum - ELSE - total_error = total_error + 1 - ENDIF - - ret_total_error = 0 -! PROBLEMS with C -! CALL test_error(ret_total_error) -! CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error) - - WRITE(*,*) - - ret_total_error = 0 - CALL test_array_compound_atomic(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Datatypes Functionality', total_error) - - ret_total_error = 0 - CALL test_array_compound_array(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Array Datatypes Functionality', total_error) - - ret_total_error = 0 - CALL t_array(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing 3-D array by dataset, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_enum(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading enum dataset, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_enum_conv(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing enumeration conversions', total_error) - - ret_total_error = 0 - CALL t_bit(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading bitfield dataset, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_opaque(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading opaque datatypes, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_objref(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading object references, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_regref(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading region references, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_vlen(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading variable-length datatypes, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_vlstring(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading variable-string datatypes, using C_LOC', total_error) - - ret_total_error = 0 - CALL t_vlstring_readwrite(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing variable-string write/read, using h5dwrite_f/h5dread_f', total_error) - - ret_total_error = 0 - CALL t_string(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing writing/reading string datatypes, using C_LOC', total_error) - - ret_total_error = 0 - CALL vl_test_special_char(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing string datatypes containing control characters', total_error) - - ret_total_error = 0 - CALL test_create(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing filling functions', total_error) - - ret_total_error = 0 - CALL test_h5kind_to_type(total_error) - CALL write_test_status(ret_total_error, ' Test function h5kind_to_type', total_error) - - ret_total_error = 0 - CALL test_array_bkg(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing Partial I/O of Array Fields in Compound Datatype FunctionalityT', total_error) - - ret_total_error = 0 - CALL test_genprop_class_callback(ret_total_error) - CALL write_test_status(ret_total_error, ' Test basic generic property list callback functionality', total_error) - - ret_total_error = 0 - CALL test_iter_group(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing group iteration functionality', total_error) - - ret_total_error = 0 - CALL test_nbit(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing nbit filter', total_error) - - ret_total_error = 0 - CALL external_test_offset(cleanup, ret_total_error) - CALL write_test_status(ret_total_error, ' Testing external dataset with offset', total_error) - - ret_total_error = 0 - CALL test_h5p_file_image(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing h5pset/get file image', total_error) - -! write(*,*) -! write(*,*) '=========================================' -! write(*,*) 'Testing GROUP interface ' -! write(*,*) '=========================================' - - ret_total_error = 0 - CALL test_h5o_refcount(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing object functions ', total_error) - - ret_total_error = 0 - CALL obj_visit(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing object visiting functions ', total_error) - - ret_total_error = 0 - CALL obj_info(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing object info functions ', total_error) - - ret_total_error = 0 - CALL test_get_file_image(ret_total_error) - CALL write_test_status(ret_total_error, ' Testing get file image ', total_error) - - - WRITE(*,*) - - WRITE(*,*) ' ============================================ ' - WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with ' - WRITE(*, fmt = '(i4)', advance='NO') total_error - WRITE(*, fmt = '(12a)' ) ' error(s) ! ' - WRITE(*,*) ' ============================================ ' - - CALL h5close_f(error) - - ! if errors detected, exit with non-zero code. - IF (total_error .NE. 0) CALL h5_exit_f(1) - -END PROGRAM fortranlibtest_F03 - - diff --git a/fortran/test/tH5A.F90 b/fortran/test/tH5A.F90 new file mode 100644 index 0000000..5b814fa --- /dev/null +++ b/fortran/test/tH5A.F90 @@ -0,0 +1,624 @@ +!****h* root/fortran/test/tH5A.f90 +! +! NAME +! tH5A.f90 +! +! FUNCTION +! Basic testing of Fortran H5A APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! attribute_test +! +! +!***** +MODULE TH5A + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + SUBROUTINE attribute_test(cleanup, total_error) + +! This subroutine tests following functionalities: +! h5acreate_f, h5awrite_f, h5aclose_f,h5aread_f, h5aopen_name_f, +! h5aget_name_f,h5aget_space_f, h5aget_type_f, +! + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=5), PARAMETER :: filename = "atest" !File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=9), PARAMETER :: dsetname = "atestdset" !Dataset name + CHARACTER(LEN=11), PARAMETER :: aname = "attr_string" !String Attribute name + CHARACTER(LEN=14), PARAMETER :: aname2 = "attr_character"!Character Attribute name + CHARACTER(LEN=11), PARAMETER :: aname3 = "attr_double" !DOuble Attribute name + CHARACTER(LEN=9), PARAMETER :: aname4 = "attr_real" !Real Attribute name + CHARACTER(LEN=12), PARAMETER :: aname5 = "attr_integer" !Integer Attribute name + CHARACTER(LEN=9), PARAMETER :: aname6 = "attr_null" !Null Attribute name + + ! + !data space rank and dimensions + ! + INTEGER, PARAMETER :: RANK = 2 + INTEGER, PARAMETER :: NX = 4 + INTEGER, PARAMETER :: NY = 5 + + + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dataspace ! Dataspace identifier for dataset + + INTEGER(HID_T) :: attr_id !String Attribute identifier + INTEGER(HID_T) :: attr2_id !Character Attribute identifier + INTEGER(HID_T) :: attr3_id !Double Attribute identifier + INTEGER(HID_T) :: attr4_id !Real Attribute identifier + INTEGER(HID_T) :: attr5_id !Integer Attribute identifier + INTEGER(HID_T) :: attr6_id !Null Attribute identifier + INTEGER(HID_T) :: aspace_id !String Attribute Dataspace identifier + INTEGER(HID_T) :: aspace2_id !Character Attribute Dataspace identifier + INTEGER(HID_T) :: aspace6_id !Null Attribute Dataspace identifier + INTEGER(HID_T) :: atype_id !String Attribute Datatype identifier + INTEGER(HID_T) :: atype2_id !Character Attribute Datatype identifier + INTEGER(HID_T) :: atype3_id !Double Attribute Datatype identifier + INTEGER(HID_T) :: atype4_id !Real Attribute Datatype identifier + INTEGER(HID_T) :: atype5_id !Integer Attribute Datatype identifier + INTEGER(HSIZE_T), DIMENSION(1) :: adims = (/2/) ! Attribute dimension + INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension + INTEGER :: arank = 1 ! Attribure rank + INTEGER(SIZE_T) :: attrlen ! Length of the attribute string + + INTEGER(HID_T) :: attr_space !Returned String Attribute Space identifier + INTEGER(HID_T) :: attr2_space !Returned other Attribute Space identifier + INTEGER(HID_T) :: attr_type !Returned Attribute Datatype identifier + INTEGER(HID_T) :: attr2_type !Returned CHARACTER Attribute Datatype identifier + INTEGER(HID_T) :: attr3_type !Returned DOUBLE Attribute Datatype identifier + INTEGER(HID_T) :: attr4_type !Returned REAL Attribute Datatype identifier + INTEGER(HID_T) :: attr5_type !Returned INTEGER Attribute Datatype identifier + INTEGER(HID_T) :: attr6_type !Returned NULL Attribute Datatype identifier + INTEGER :: num_attrs !number of attributes + INTEGER(HSIZE_T) :: attr_storage ! attributes storage requirements .MSB. + CHARACTER(LEN=256) :: attr_name !buffer to put attr_name + INTEGER(SIZE_T) :: name_size = 80 !attribute name length + + CHARACTER(LEN=35), DIMENSION(2) :: attr_data ! String attribute data + CHARACTER(LEN=35), DIMENSION(2) :: aread_data ! Buffer to put read back + ! string attr data + CHARACTER :: attr_character_data = 'A' + REAL(KIND=Fortran_DOUBLE), DIMENSION(1) :: attr_double_data = 3.459D0 + REAL, DIMENSION(1) :: attr_real_data = 4.0 + INTEGER, DIMENSION(1) :: attr_integer_data = 5 + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + + CHARACTER :: aread_character_data ! variable to put read back Character attr data + INTEGER, DIMENSION(1) :: aread_integer_data ! variable to put read back integer attr data + INTEGER, DIMENSION(1) :: aread_null_data = 7 ! variable to put read back null attr data + REAL(KIND=Fortran_DOUBLE), DIMENSION(1) :: aread_double_data ! variable to put read back double attr data + REAL, DIMENSION(1) :: aread_real_data ! variable to put read back real attr data + + ! + !general purpose integer + ! + INTEGER :: i, j + INTEGER :: error ! Error flag + + ! + !The dimensions for the dataset. + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/NX,NY/) + + ! + !data buffers + ! + INTEGER, DIMENSION(NX,NY) :: data_in + + ! + !Initialize data_in buffer + ! + DO i = 1, NX + DO j = 1, NY + data_in(i,j) = (i-1) + (j-1) + END DO + END DO + ! + ! Initialize attribute's data + ! + attr_data(1) = 'Dataset character attribute' + attr_data(2) = 'Some other string here ' + attrlen = LEN(attr_data(1)) + + ! + ! Create the file. + ! + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + WRITE(*,*) "Cannot modify file name" + STOP + 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 in the file. + ! + CALL h5dcreate_f(file_id, dsetname, 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) + + ! + ! Create scalar data space for the String attribute. + ! + CALL h5screate_simple_f(arank, adims, aspace_id, error) + CALL check("h5screate_simple_f",error,total_error) + ! + ! Create scalar data space for all other attributes. + ! + CALL h5screate_simple_f(arank, adims2, aspace2_id, error) + CALL check("h5screate_simple_f",error,total_error) + ! + ! Create null data space for null attributes. + ! + CALL h5screate_f(H5S_NULL_F, aspace6_id, error) + CALL check("h5screate_f",error,total_error) + + ! + ! Create datatype for the String attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error) + CALL check("h5tcopy_f",error,total_error) + + CALL h5tset_size_f(atype_id, attrlen, error) + CALL check("h5tset_size_f",error,total_error) + + ! + ! Create datatype for the Character attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype2_id, error) + CALL check("h5tcopy_f",error,total_error) + ! + ! Create datatype for the Double attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_DOUBLE, atype3_id, error) + CALL check("h5tcopy_f",error,total_error) + ! + ! Create datatype for the Real attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_REAL, atype4_id, error) + CALL check("h5tcopy_f",error,total_error) + ! + ! Create datatype for the Integer attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_INTEGER, atype5_id, error) + CALL check("h5tcopy_f",error,total_error) + + + ! + ! Create dataset String attribute. + ! + CALL h5acreate_f(dset_id, aname, atype_id, aspace_id, & + attr_id, error) + CALL check("h5acreate_f",error,total_error) + + + ! + ! Create dataset CHARACTER attribute. + ! + CALL h5acreate_f(dset_id, aname2, atype2_id, aspace2_id, & + attr2_id, error) + CALL check("h5acreate_f",error,total_error) + + + ! + ! Create dataset DOUBLE attribute. + ! + CALL h5acreate_f(dset_id, aname3, atype3_id, aspace2_id, & + attr3_id, error) + CALL check("h5acreate_f",error,total_error) + ! + ! Create dataset REAL attribute. + ! + CALL h5acreate_f(dset_id, aname4, atype4_id, aspace2_id, & + attr4_id, error) + CALL check("h5acreate_f",error,total_error) + ! + ! Create dataset INTEGER attribute. + ! + CALL h5acreate_f(dset_id, aname5, atype5_id, aspace2_id, & + attr5_id, error) + CALL check("h5acreate_f",error,total_error) + ! + ! Create dataset NULL attribute of INTEGER. + ! + + CALL h5acreate_f(dset_id, aname6, atype5_id, aspace6_id, & + attr6_id, error) + + CALL check("h5acreate_f",error,total_error) + + ! + ! Write the String attribute data. + ! + data_dims(1) = 2 + CALL h5awrite_f(attr_id, atype_id, attr_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ! + ! Write the Character attribute data. + ! + CALL h5awrite_f(attr2_id, atype2_id, attr_character_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ! + ! Write the DOUBLE attribute data. + ! + data_dims(1) = 1 + CALL h5awrite_f(attr3_id, atype3_id, attr_double_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ! + ! Write the Real attribute data. + ! + data_dims(1) = 1 + CALL h5awrite_f(attr4_id, atype4_id, attr_real_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! + ! Write the Integer attribute data. + ! + data_dims(1) = 1 + CALL h5awrite_f(attr5_id, atype5_id, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! + ! Write the NULL attribute data(nothing can be written). + ! + CALL h5awrite_f(attr6_id, atype5_id, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! + ! check the amount of storage that is required for the specified attribute .MSB. + ! + CALL h5aget_storage_size_f(attr_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,*SizeOf(attr_storage),total_error) + CALL h5aget_storage_size_f(attr2_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,1,total_error) + CALL h5aget_storage_size_f(attr3_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,8,total_error) + CALL h5aget_storage_size_f(attr4_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,4,total_error) + CALL h5aget_storage_size_f(attr5_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,4,total_error) + CALL h5aget_storage_size_f(attr6_id, attr_storage, error) + CALL check("h5aget_storage_size_f",error,total_error) +! CALL verify("h5aget_storage_size_f",attr_storage,0,total_error) + + + ! + ! Close the attribute. + ! + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr2_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr3_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr4_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr5_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr6_id, error) + CALL check("h5aclose_f",error,total_error) + + CALL h5tclose_f(atype_id, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(atype2_id, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(atype3_id, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(atype4_id, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(atype5_id, error) + CALL check("h5tclose_f",error,total_error) + + ! + ! Terminate access to the data space. + ! + CALL h5sclose_f(aspace_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(aspace2_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(aspace6_id, error) + CALL check("h5sclose_f",error,total_error) + ! + ! Terminate access to the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + ! + ! Terminate access to the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + ! + ! Open file + ! + CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5open_f",error,total_error) + ! + ! Reopen dataset + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f",error,total_error) + ! + !open the String attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname, attr_id, error) + CALL check("h5aopen_name_f",error,total_error) + + ! + !open the CHARACTER attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname2, attr2_id, error) + CALL check("h5aopen_name_f",error,total_error) + ! + !open the DOUBLE attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname3, attr3_id, error) + CALL check("h5aopen_name_f",error,total_error) + ! + !open the REAL attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname4, attr4_id, error) + CALL check("h5aopen_name_f",error,total_error) + + ! + !open the INTEGER attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname5, attr5_id, error) + CALL check("h5aopen_idx_f",error,total_error) + + ! + !open the NULL attrbute by name + ! + CALL h5aopen_name_f(dset_id, aname6, attr6_id, error) + CALL check("h5aopen_idx_f",error,total_error) + + ! + !get the attrbute name + ! + CALL h5aget_name_f(attr5_id, name_size, attr_name, error) + CALL check("h5aget_name_f",error,total_error) + IF (attr_name(1:12) .NE. aname5) THEN + total_error = total_error + 1 + END IF + IF (error .NE. 12) THEN + total_error = total_error + 1 + END IF + + ! + !get the STRING attrbute space + ! + CALL h5aget_space_f(attr_id, attr_space, error) + CALL check("h5aget_space_f",error,total_error) + ! + !get other attrbute space + ! + CALL h5aget_space_f(attr2_id, attr2_space, error) + CALL check("h5aget_space_f",error,total_error) + ! + !get the string attrbute datatype + ! + CALL h5aget_type_f(attr_id, attr_type, error) + CALL check("h5aget_type_f",error,total_error) + ! + !get the character attrbute datatype + ! + CALL h5aget_type_f(attr2_id, attr2_type, error) + CALL check("h5aget_type_f",error,total_error) + ! + !get the double attrbute datatype + ! + CALL h5aget_type_f(attr3_id, attr3_type, error) + CALL check("h5aget_type_f",error,total_error) + ! + !get the real attrbute datatype + ! + CALL h5aget_type_f(attr4_id, attr4_type, error) + CALL check("h5aget_type_f",error,total_error) + + ! + !get the integer attrbute datatype + ! + CALL h5aget_type_f(attr5_id, attr5_type, error) + CALL check("h5aget_type_f",error,total_error) + + ! + !get the null attrbute datatype + ! + CALL h5aget_type_f(attr6_id, attr6_type, error) + CALL check("h5aget_type_f",error,total_error) + + ! + !get number of attributes + ! + CALL h5aget_num_attrs_f(dset_id, num_attrs, error) + CALL check("h5aget_num_attrs_f",error,total_error) + IF (num_attrs .NE. 6) THEN + WRITE(*,*) "got number of attributes wrong", num_attrs + total_error = total_error +1 + END IF + + ! + !set the read back data type's size + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error) + CALL check("h5tcopy_f",error,total_error) + + CALL h5tset_size_f(atype_id, attrlen, error) + CALL check("h5tset_size_f",error,total_error) + ! + !read the string attribute data back to memory + ! + data_dims(1) = 2 + CALL h5aread_f(attr_id, atype_id, aread_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + + IF ( (aread_data(1) .NE. attr_data(1)) .OR. (aread_data(2) .NE. attr_data(2)) ) THEN + WRITE(*,*) "Read back string attrbute is wrong", aread_data(1), aread_data(2) + total_error = total_error + 1 + END IF + + ! + !read the CHARACTER attribute data back to memory + ! + CALL h5aread_f(attr2_id, H5T_NATIVE_CHARACTER, aread_character_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + IF (aread_character_data .NE. 'A' ) THEN + WRITE(*,*) "Read back character attrbute is wrong ",aread_character_data + total_error = total_error + 1 + END IF + ! + !read the double attribute data back to memory + ! + data_dims(1) = 1 + CALL h5aread_f(attr3_id, H5T_NATIVE_DOUBLE, aread_double_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + CALL VERIFY("Read back double attrbute is wrong", aread_double_data(1),3.459_Fortran_DOUBLE,total_error) + + ! + !read the real attribute data back to memory + ! + data_dims(1) = 1 + CALL h5aread_f(attr4_id, H5T_NATIVE_REAL, aread_real_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + CALL VERIFY("Read back real attrbute is wrong", aread_real_data(1),4.0,total_error) + ! + !read the Integer attribute data back to memory + ! + data_dims(1) = 1 + CALL h5aread_f(attr5_id, H5T_NATIVE_INTEGER, aread_integer_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + IF (aread_integer_data(1) .NE. 5 ) THEN + WRITE(*,*) "Read back integer attrbute is wrong ", aread_integer_data + total_error = total_error + 1 + END IF + ! + !read the null attribute data. nothing can be read. + ! + data_dims(1) = 1 + CALL h5aread_f(attr6_id, H5T_NATIVE_INTEGER, aread_null_data, data_dims, error) + CALL check("h5aread_f",error,total_error) + IF (aread_null_data(1) .NE. 7 ) THEN + WRITE(*,*) "Read back null attrbute is wrong ", aread_null_data + total_error = total_error + 1 + END IF + + ! + ! Close the attribute. + ! + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr2_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr3_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr4_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr5_id, error) + CALL check("h5aclose_f",error,total_error) + CALL h5aclose_f(attr6_id, error) + CALL check("h5aclose_f",error,total_error) + + ! + ! Delete the attribute from the Dataset. + ! + CALL h5adelete_f(dset_id, aname, error) + CALL check("h5adelete_f",error,total_error) + + ! + !get number of attributes + ! + CALL h5aget_num_attrs_f(dset_id, num_attrs, error) + CALL check("h5aget_num_attrs_f",error,total_error) + IF (num_attrs .NE. 5) THEN + WRITE(*,*) "got number of attributes wrong", num_attrs + total_error = total_error +1 + END IF + + + + CALL h5sclose_f(attr_space, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(attr2_space, error) + CALL check("h5sclose_f",error,total_error) + + ! + ! Terminate access to the data type. + ! + CALL h5tclose_f(attr_type, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(attr2_type, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(attr3_type, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(attr4_type, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(attr5_type, error) + CALL check("h5tclose_f",error,total_error) + CALL h5tclose_f(attr6_type, error) + CALL check("h5tclose_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) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + ! + ! Remove the file + ! + IF (cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + + RETURN + END SUBROUTINE attribute_test +END MODULE TH5A diff --git a/fortran/test/tH5A.f90 b/fortran/test/tH5A.f90 deleted file mode 100644 index 5b814fa..0000000 --- a/fortran/test/tH5A.f90 +++ /dev/null @@ -1,624 +0,0 @@ -!****h* root/fortran/test/tH5A.f90 -! -! NAME -! tH5A.f90 -! -! FUNCTION -! Basic testing of Fortran H5A APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! attribute_test -! -! -!***** -MODULE TH5A - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - SUBROUTINE attribute_test(cleanup, total_error) - -! This subroutine tests following functionalities: -! h5acreate_f, h5awrite_f, h5aclose_f,h5aread_f, h5aopen_name_f, -! h5aget_name_f,h5aget_space_f, h5aget_type_f, -! - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=5), PARAMETER :: filename = "atest" !File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=9), PARAMETER :: dsetname = "atestdset" !Dataset name - CHARACTER(LEN=11), PARAMETER :: aname = "attr_string" !String Attribute name - CHARACTER(LEN=14), PARAMETER :: aname2 = "attr_character"!Character Attribute name - CHARACTER(LEN=11), PARAMETER :: aname3 = "attr_double" !DOuble Attribute name - CHARACTER(LEN=9), PARAMETER :: aname4 = "attr_real" !Real Attribute name - CHARACTER(LEN=12), PARAMETER :: aname5 = "attr_integer" !Integer Attribute name - CHARACTER(LEN=9), PARAMETER :: aname6 = "attr_null" !Null Attribute name - - ! - !data space rank and dimensions - ! - INTEGER, PARAMETER :: RANK = 2 - INTEGER, PARAMETER :: NX = 4 - INTEGER, PARAMETER :: NY = 5 - - - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dataspace ! Dataspace identifier for dataset - - INTEGER(HID_T) :: attr_id !String Attribute identifier - INTEGER(HID_T) :: attr2_id !Character Attribute identifier - INTEGER(HID_T) :: attr3_id !Double Attribute identifier - INTEGER(HID_T) :: attr4_id !Real Attribute identifier - INTEGER(HID_T) :: attr5_id !Integer Attribute identifier - INTEGER(HID_T) :: attr6_id !Null Attribute identifier - INTEGER(HID_T) :: aspace_id !String Attribute Dataspace identifier - INTEGER(HID_T) :: aspace2_id !Character Attribute Dataspace identifier - INTEGER(HID_T) :: aspace6_id !Null Attribute Dataspace identifier - INTEGER(HID_T) :: atype_id !String Attribute Datatype identifier - INTEGER(HID_T) :: atype2_id !Character Attribute Datatype identifier - INTEGER(HID_T) :: atype3_id !Double Attribute Datatype identifier - INTEGER(HID_T) :: atype4_id !Real Attribute Datatype identifier - INTEGER(HID_T) :: atype5_id !Integer Attribute Datatype identifier - INTEGER(HSIZE_T), DIMENSION(1) :: adims = (/2/) ! Attribute dimension - INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension - INTEGER :: arank = 1 ! Attribure rank - INTEGER(SIZE_T) :: attrlen ! Length of the attribute string - - INTEGER(HID_T) :: attr_space !Returned String Attribute Space identifier - INTEGER(HID_T) :: attr2_space !Returned other Attribute Space identifier - INTEGER(HID_T) :: attr_type !Returned Attribute Datatype identifier - INTEGER(HID_T) :: attr2_type !Returned CHARACTER Attribute Datatype identifier - INTEGER(HID_T) :: attr3_type !Returned DOUBLE Attribute Datatype identifier - INTEGER(HID_T) :: attr4_type !Returned REAL Attribute Datatype identifier - INTEGER(HID_T) :: attr5_type !Returned INTEGER Attribute Datatype identifier - INTEGER(HID_T) :: attr6_type !Returned NULL Attribute Datatype identifier - INTEGER :: num_attrs !number of attributes - INTEGER(HSIZE_T) :: attr_storage ! attributes storage requirements .MSB. - CHARACTER(LEN=256) :: attr_name !buffer to put attr_name - INTEGER(SIZE_T) :: name_size = 80 !attribute name length - - CHARACTER(LEN=35), DIMENSION(2) :: attr_data ! String attribute data - CHARACTER(LEN=35), DIMENSION(2) :: aread_data ! Buffer to put read back - ! string attr data - CHARACTER :: attr_character_data = 'A' - REAL(KIND=Fortran_DOUBLE), DIMENSION(1) :: attr_double_data = 3.459D0 - REAL, DIMENSION(1) :: attr_real_data = 4.0 - INTEGER, DIMENSION(1) :: attr_integer_data = 5 - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - - CHARACTER :: aread_character_data ! variable to put read back Character attr data - INTEGER, DIMENSION(1) :: aread_integer_data ! variable to put read back integer attr data - INTEGER, DIMENSION(1) :: aread_null_data = 7 ! variable to put read back null attr data - REAL(KIND=Fortran_DOUBLE), DIMENSION(1) :: aread_double_data ! variable to put read back double attr data - REAL, DIMENSION(1) :: aread_real_data ! variable to put read back real attr data - - ! - !general purpose integer - ! - INTEGER :: i, j - INTEGER :: error ! Error flag - - ! - !The dimensions for the dataset. - ! - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/NX,NY/) - - ! - !data buffers - ! - INTEGER, DIMENSION(NX,NY) :: data_in - - ! - !Initialize data_in buffer - ! - DO i = 1, NX - DO j = 1, NY - data_in(i,j) = (i-1) + (j-1) - END DO - END DO - ! - ! Initialize attribute's data - ! - attr_data(1) = 'Dataset character attribute' - attr_data(2) = 'Some other string here ' - attrlen = LEN(attr_data(1)) - - ! - ! Create the file. - ! - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - IF (error .NE. 0) THEN - WRITE(*,*) "Cannot modify file name" - STOP - 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 in the file. - ! - CALL h5dcreate_f(file_id, dsetname, 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) - - ! - ! Create scalar data space for the String attribute. - ! - CALL h5screate_simple_f(arank, adims, aspace_id, error) - CALL check("h5screate_simple_f",error,total_error) - ! - ! Create scalar data space for all other attributes. - ! - CALL h5screate_simple_f(arank, adims2, aspace2_id, error) - CALL check("h5screate_simple_f",error,total_error) - ! - ! Create null data space for null attributes. - ! - CALL h5screate_f(H5S_NULL_F, aspace6_id, error) - CALL check("h5screate_f",error,total_error) - - ! - ! Create datatype for the String attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error) - CALL check("h5tcopy_f",error,total_error) - - CALL h5tset_size_f(atype_id, attrlen, error) - CALL check("h5tset_size_f",error,total_error) - - ! - ! Create datatype for the Character attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype2_id, error) - CALL check("h5tcopy_f",error,total_error) - ! - ! Create datatype for the Double attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_DOUBLE, atype3_id, error) - CALL check("h5tcopy_f",error,total_error) - ! - ! Create datatype for the Real attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_REAL, atype4_id, error) - CALL check("h5tcopy_f",error,total_error) - ! - ! Create datatype for the Integer attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_INTEGER, atype5_id, error) - CALL check("h5tcopy_f",error,total_error) - - - ! - ! Create dataset String attribute. - ! - CALL h5acreate_f(dset_id, aname, atype_id, aspace_id, & - attr_id, error) - CALL check("h5acreate_f",error,total_error) - - - ! - ! Create dataset CHARACTER attribute. - ! - CALL h5acreate_f(dset_id, aname2, atype2_id, aspace2_id, & - attr2_id, error) - CALL check("h5acreate_f",error,total_error) - - - ! - ! Create dataset DOUBLE attribute. - ! - CALL h5acreate_f(dset_id, aname3, atype3_id, aspace2_id, & - attr3_id, error) - CALL check("h5acreate_f",error,total_error) - ! - ! Create dataset REAL attribute. - ! - CALL h5acreate_f(dset_id, aname4, atype4_id, aspace2_id, & - attr4_id, error) - CALL check("h5acreate_f",error,total_error) - ! - ! Create dataset INTEGER attribute. - ! - CALL h5acreate_f(dset_id, aname5, atype5_id, aspace2_id, & - attr5_id, error) - CALL check("h5acreate_f",error,total_error) - ! - ! Create dataset NULL attribute of INTEGER. - ! - - CALL h5acreate_f(dset_id, aname6, atype5_id, aspace6_id, & - attr6_id, error) - - CALL check("h5acreate_f",error,total_error) - - ! - ! Write the String attribute data. - ! - data_dims(1) = 2 - CALL h5awrite_f(attr_id, atype_id, attr_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ! - ! Write the Character attribute data. - ! - CALL h5awrite_f(attr2_id, atype2_id, attr_character_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ! - ! Write the DOUBLE attribute data. - ! - data_dims(1) = 1 - CALL h5awrite_f(attr3_id, atype3_id, attr_double_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ! - ! Write the Real attribute data. - ! - data_dims(1) = 1 - CALL h5awrite_f(attr4_id, atype4_id, attr_real_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! - ! Write the Integer attribute data. - ! - data_dims(1) = 1 - CALL h5awrite_f(attr5_id, atype5_id, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! - ! Write the NULL attribute data(nothing can be written). - ! - CALL h5awrite_f(attr6_id, atype5_id, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! - ! check the amount of storage that is required for the specified attribute .MSB. - ! - CALL h5aget_storage_size_f(attr_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,*SizeOf(attr_storage),total_error) - CALL h5aget_storage_size_f(attr2_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,1,total_error) - CALL h5aget_storage_size_f(attr3_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,8,total_error) - CALL h5aget_storage_size_f(attr4_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,4,total_error) - CALL h5aget_storage_size_f(attr5_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,4,total_error) - CALL h5aget_storage_size_f(attr6_id, attr_storage, error) - CALL check("h5aget_storage_size_f",error,total_error) -! CALL verify("h5aget_storage_size_f",attr_storage,0,total_error) - - - ! - ! Close the attribute. - ! - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr2_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr3_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr4_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr5_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr6_id, error) - CALL check("h5aclose_f",error,total_error) - - CALL h5tclose_f(atype_id, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(atype2_id, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(atype3_id, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(atype4_id, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(atype5_id, error) - CALL check("h5tclose_f",error,total_error) - - ! - ! Terminate access to the data space. - ! - CALL h5sclose_f(aspace_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(aspace2_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(aspace6_id, error) - CALL check("h5sclose_f",error,total_error) - ! - ! Terminate access to the dataset. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - ! - ! Terminate access to the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - ! - ! Open file - ! - CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5open_f",error,total_error) - ! - ! Reopen dataset - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f",error,total_error) - ! - !open the String attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname, attr_id, error) - CALL check("h5aopen_name_f",error,total_error) - - ! - !open the CHARACTER attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname2, attr2_id, error) - CALL check("h5aopen_name_f",error,total_error) - ! - !open the DOUBLE attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname3, attr3_id, error) - CALL check("h5aopen_name_f",error,total_error) - ! - !open the REAL attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname4, attr4_id, error) - CALL check("h5aopen_name_f",error,total_error) - - ! - !open the INTEGER attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname5, attr5_id, error) - CALL check("h5aopen_idx_f",error,total_error) - - ! - !open the NULL attrbute by name - ! - CALL h5aopen_name_f(dset_id, aname6, attr6_id, error) - CALL check("h5aopen_idx_f",error,total_error) - - ! - !get the attrbute name - ! - CALL h5aget_name_f(attr5_id, name_size, attr_name, error) - CALL check("h5aget_name_f",error,total_error) - IF (attr_name(1:12) .NE. aname5) THEN - total_error = total_error + 1 - END IF - IF (error .NE. 12) THEN - total_error = total_error + 1 - END IF - - ! - !get the STRING attrbute space - ! - CALL h5aget_space_f(attr_id, attr_space, error) - CALL check("h5aget_space_f",error,total_error) - ! - !get other attrbute space - ! - CALL h5aget_space_f(attr2_id, attr2_space, error) - CALL check("h5aget_space_f",error,total_error) - ! - !get the string attrbute datatype - ! - CALL h5aget_type_f(attr_id, attr_type, error) - CALL check("h5aget_type_f",error,total_error) - ! - !get the character attrbute datatype - ! - CALL h5aget_type_f(attr2_id, attr2_type, error) - CALL check("h5aget_type_f",error,total_error) - ! - !get the double attrbute datatype - ! - CALL h5aget_type_f(attr3_id, attr3_type, error) - CALL check("h5aget_type_f",error,total_error) - ! - !get the real attrbute datatype - ! - CALL h5aget_type_f(attr4_id, attr4_type, error) - CALL check("h5aget_type_f",error,total_error) - - ! - !get the integer attrbute datatype - ! - CALL h5aget_type_f(attr5_id, attr5_type, error) - CALL check("h5aget_type_f",error,total_error) - - ! - !get the null attrbute datatype - ! - CALL h5aget_type_f(attr6_id, attr6_type, error) - CALL check("h5aget_type_f",error,total_error) - - ! - !get number of attributes - ! - CALL h5aget_num_attrs_f(dset_id, num_attrs, error) - CALL check("h5aget_num_attrs_f",error,total_error) - IF (num_attrs .NE. 6) THEN - WRITE(*,*) "got number of attributes wrong", num_attrs - total_error = total_error +1 - END IF - - ! - !set the read back data type's size - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error) - CALL check("h5tcopy_f",error,total_error) - - CALL h5tset_size_f(atype_id, attrlen, error) - CALL check("h5tset_size_f",error,total_error) - ! - !read the string attribute data back to memory - ! - data_dims(1) = 2 - CALL h5aread_f(attr_id, atype_id, aread_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - - IF ( (aread_data(1) .NE. attr_data(1)) .OR. (aread_data(2) .NE. attr_data(2)) ) THEN - WRITE(*,*) "Read back string attrbute is wrong", aread_data(1), aread_data(2) - total_error = total_error + 1 - END IF - - ! - !read the CHARACTER attribute data back to memory - ! - CALL h5aread_f(attr2_id, H5T_NATIVE_CHARACTER, aread_character_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - IF (aread_character_data .NE. 'A' ) THEN - WRITE(*,*) "Read back character attrbute is wrong ",aread_character_data - total_error = total_error + 1 - END IF - ! - !read the double attribute data back to memory - ! - data_dims(1) = 1 - CALL h5aread_f(attr3_id, H5T_NATIVE_DOUBLE, aread_double_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - CALL VERIFY("Read back double attrbute is wrong", aread_double_data(1),3.459_Fortran_DOUBLE,total_error) - - ! - !read the real attribute data back to memory - ! - data_dims(1) = 1 - CALL h5aread_f(attr4_id, H5T_NATIVE_REAL, aread_real_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - CALL VERIFY("Read back real attrbute is wrong", aread_real_data(1),4.0,total_error) - ! - !read the Integer attribute data back to memory - ! - data_dims(1) = 1 - CALL h5aread_f(attr5_id, H5T_NATIVE_INTEGER, aread_integer_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - IF (aread_integer_data(1) .NE. 5 ) THEN - WRITE(*,*) "Read back integer attrbute is wrong ", aread_integer_data - total_error = total_error + 1 - END IF - ! - !read the null attribute data. nothing can be read. - ! - data_dims(1) = 1 - CALL h5aread_f(attr6_id, H5T_NATIVE_INTEGER, aread_null_data, data_dims, error) - CALL check("h5aread_f",error,total_error) - IF (aread_null_data(1) .NE. 7 ) THEN - WRITE(*,*) "Read back null attrbute is wrong ", aread_null_data - total_error = total_error + 1 - END IF - - ! - ! Close the attribute. - ! - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr2_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr3_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr4_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr5_id, error) - CALL check("h5aclose_f",error,total_error) - CALL h5aclose_f(attr6_id, error) - CALL check("h5aclose_f",error,total_error) - - ! - ! Delete the attribute from the Dataset. - ! - CALL h5adelete_f(dset_id, aname, error) - CALL check("h5adelete_f",error,total_error) - - ! - !get number of attributes - ! - CALL h5aget_num_attrs_f(dset_id, num_attrs, error) - CALL check("h5aget_num_attrs_f",error,total_error) - IF (num_attrs .NE. 5) THEN - WRITE(*,*) "got number of attributes wrong", num_attrs - total_error = total_error +1 - END IF - - - - CALL h5sclose_f(attr_space, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(attr2_space, error) - CALL check("h5sclose_f",error,total_error) - - ! - ! Terminate access to the data type. - ! - CALL h5tclose_f(attr_type, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(attr2_type, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(attr3_type, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(attr4_type, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(attr5_type, error) - CALL check("h5tclose_f",error,total_error) - CALL h5tclose_f(attr6_type, error) - CALL check("h5tclose_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) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - ! - ! Remove the file - ! - IF (cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - - RETURN - END SUBROUTINE attribute_test -END MODULE TH5A diff --git a/fortran/test/tH5A_1_8.F90 b/fortran/test/tH5A_1_8.F90 new file mode 100644 index 0000000..c70e288 --- /dev/null +++ b/fortran/test/tH5A_1_8.F90 @@ -0,0 +1,2779 @@ +!****h* root/fortran/test/tH5A_1_8.f90 +! +! NAME +! tH5A_1_8.f90 +! +! FUNCTION +! Basic testing of Fortran H5A APIs introduced in 1.8. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! attribute_test_1_8, test_attr_corder_create_compact, test_attr_null_space, +! test_attr_create_by_name, test_attr_info_by_idx, attr_info_by_idx_check, +! test_attr_shared_rename, test_attr_delete_by_idx, test_attr_shared_delete, +! test_attr_dense_open, test_attr_dense_verify, test_attr_corder_create_basic, +! test_attr_basic_write, test_attr_many, attr_open_check, +! +!***** +MODULE TH5A_1_8 + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS +SUBROUTINE attribute_test_1_8(cleanup, total_error) + +! This subroutine tests following 1.8 functionalities: +! h5acreate_f, h5awrite_f, h5aclose_f,h5aread_f, h5aopen_name_f, +! h5aget_name_f,h5aget_space_f, h5aget_type_f, H5Pset_shared_mesg_nindexes_f, +! H5Pset_shared_mesg_index_f +! + + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + ! + !general purpose integer + ! + INTEGER :: i, j + INTEGER :: error ! Error flag + + ! NEW STARTS HERE + INTEGER(HID_T) :: fapl = -1, fapl2 = -1 + INTEGER(HID_T) :: fcpl = -1, fcpl2 = -1 + INTEGER(HID_T) :: my_fapl, my_fcpl + LOGICAL, DIMENSION(1:2) :: new_format = (/.TRUE.,.FALSE./) + LOGICAL, DIMENSION(1:2) :: use_shared = (/.TRUE.,.FALSE./) + + INTEGER :: ret_total_error + +! ******************** +! test_attr equivelent +! ******************** + +! WRITE(*,*) "TESTING ATTRIBUTES" + + CALL H5Pcreate_f(H5P_FILE_ACCESS_F,fapl,error) + CALL check("h5Pcreate_f",error,total_error) + CALL h5pcopy_f(fapl, fapl2, error) + CALL check("h5pcopy_f",error,total_error) + + CALL H5Pcreate_f(H5P_FILE_CREATE_F,fcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + CALL h5pcopy_f(fcpl, fcpl2, error) + CALL check("h5pcopy_f",error,total_error) + + CALL H5Pset_shared_mesg_nindexes_f(fcpl2,1,error) + CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) + + CALL H5Pset_shared_mesg_index_f(fcpl2, 0, H5O_SHMESG_ATTR_FLAG_F, 1, error) + CALL check(" H5Pset_shared_mesg_index_f",error, total_error) + + DO i = 1, 2 + + IF (new_format(i)) THEN + WRITE(*,'(1X,A)') "Testing with new file format:" + my_fapl = fapl2 + ELSE + WRITE(*,'(1X,A)') "Testing with old file format:" + my_fapl = fapl + END IF + ret_total_error = 0 + CALL test_attr_basic_write(my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Tests INT attributes on both datasets and groups', & + total_error) + + IF(new_format(i)) THEN + DO j = 1, 2 + IF (use_shared(j)) THEN + WRITE(*,*) " - Testing with shared attributes:" + my_fcpl = fcpl2 + ELSE + WRITE(*,*) " - Testing without shared attributes:" + my_fcpl = fcpl + END IF + + ret_total_error = 0 + CALL test_attr_dense_open(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing INT attributes on both datasets and groups', & + total_error) + + ret_total_error = 0 + CALL test_attr_null_space(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing storing attribute with "null" dataspace', & + total_error) + ret_total_error = 0 + CALL test_attr_many(new_format(i), my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing storing lots of attributes', & + total_error) + + ret_total_error = 0 + CALL test_attr_corder_create_basic(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing creating objects with attribute creation order', & + total_error) + + ret_total_error = 0 + CALL test_attr_corder_create_compact(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing compact storage on objects with attribute creation order', & + total_error) + ret_total_error = 0 + CALL test_attr_info_by_idx(new_format(i), my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing querying attribute info by index', & + total_error) + + ret_total_error = 0 + CALL test_attr_delete_by_idx(new_format(i), my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing deleting attribute by index', & + total_error) + + ret_total_error = 0 + CALL test_attr_create_by_name(new_format(i), my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' - Testing creating attributes by name', & + total_error) + + ! More complex tests with both "new format" and "shared" attributes + IF( use_shared(j) ) THEN + ret_total_error = 0 + CALL test_attr_shared_rename(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error,& + ' - Testing renaming shared attributes in "compact" & "dense" storage', & + total_error) + + ret_total_error = 0 + CALL test_attr_shared_delete(my_fcpl, my_fapl, ret_total_error) + CALL write_test_status(ret_total_error,& + ' - Testing deleting shared attributes in "compact" & "dense" storage', & + total_error) + + END IF + END DO + END IF + ENDDO + + CALL H5Pclose_f(fcpl, error) + CALL CHECK("H5Pclose", error,total_error) + CALL H5Pclose_f(fcpl2, error) + CALL CHECK("H5Pclose", error,total_error) + + IF(cleanup) CALL h5_cleanup_f("tattr", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + + RETURN +END SUBROUTINE attribute_test_1_8 + +SUBROUTINE test_attr_corder_create_compact(fcpl,fapl, total_error) + +!*************************************************************** +!** +!** test_attr_corder_create_compact(): Test basic H5A (attribute) code. +!** Tests compact attribute storage on objects with attribute creation order info +!** +!*************************************************************** + +! Needed for get_info_by_name + + + IMPLICIT NONE + +! - - - arg types - - - + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid + + INTEGER :: error + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" + INTEGER, PARAMETER :: NUM_DSETS = 3 + + INTEGER :: curr_dset + + INTEGER(HID_T) :: dset1, dset2, dset3 + INTEGER(HID_T) :: my_dataset + + INTEGER :: u + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=7) :: attrname + CHARACTER(LEN=2) :: chr2 + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + + data_dims = 0 + +! WRITE(*,*) " - Testing Compact Storage of Attributes with Creation Order Info" + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + ! Create dataset creation property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), error) + CALL check("H5Pset_attr_creation_order",error,total_error) + + ! Query the attribute creation properties + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl ) + CALL check("h5dcreate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + END SELECT + DO u = 0, max_compact - 1 + ! Create attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error) + CALL check("h5acreate_f",error,total_error) + + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + END DO + END DO + + ! Close Datasets + CALL h5dclose_f(dset1, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset2, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset3, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + + ! Close property list + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f",error,total_error) + + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) + CALL check("h5open_f",error,total_error) + + CALL h5dopen_f(fid, DSET1_NAME, dset1, error) + CALL check("h5dopen_f",error,total_error) + CALL h5dopen_f(fid, DSET2_NAME, dset2, error) + CALL check("h5dopen_f",error,total_error) + CALL h5dopen_f(fid, DSET3_NAME, dset3, error) + CALL check("h5dopen_f",error,total_error) + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + CASE DEFAULT + WRITE(*,*) " WARNING: To many data sets! " + END SELECT + DO u = 0,max_compact-1 + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + ! Retrieve information for attribute + + CALL H5Aget_info_by_name_f(my_dataset, ".", attrname, & + f_corder_valid, corder, cset, data_size, error, lapl_id = H5P_DEFAULT_F ) !with optional + + CALL check("H5Aget_info_by_name_f", error, total_error) + + ! Verify creation order of attribute + + CALL verify("H5Aget_info_by_name_f", f_corder_valid, .TRUE., total_error) + CALL verify("H5Aget_info_by_name_f", corder, u, total_error) + + + ! Retrieve information for attribute + + CALL H5Aget_info_by_name_f(my_dataset, ".", attrname, & + f_corder_valid, corder, cset, data_size, error) ! without optional + + CALL check("H5Aget_info_by_name_f", error, total_error) + + ! Verify creation order of attribute + + CALL verify("H5Aget_info_by_name_f", f_corder_valid, .TRUE., total_error) + CALL verify("H5Aget_info_by_name_f", corder, u, total_error) + + END DO + END DO + ! Close Datasets + CALL h5dclose_f(dset1, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset2, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset3, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + +END SUBROUTINE test_attr_corder_create_compact + +SUBROUTINE test_attr_null_space(fcpl, fapl, total_error) +!*************************************************************** +!** +!** test_attr_null_space(): Test basic H5A (attribute) code. +!** Tests storing attribute with "null" dataspace +!** +!*************************************************************** + + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: sid, null_sid + INTEGER(HID_T) :: dataset + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + + INTEGER :: error + + INTEGER :: value_scalar + INTEGER, DIMENSION(1) :: value + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HID_T) :: attr_sid + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + INTEGER(HSIZE_T) :: storage_size ! attributes storage requirements + + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + + LOGICAL :: equal + + ! test: H5Sextent_equal_f + + data_dims = 0 + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Re-open file + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error) + CALL check("h5open_f",error,total_error) + ! Create dataspace for dataset attributes + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + ! Create "null" dataspace for attribute + CALL h5screate_f(H5S_NULL_F, null_sid, error) + CALL check("h5screate_f",error,total_error) + ! Create a dataset + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error) + CALL check("h5dcreate_f",error,total_error) + ! Add attribute with 'null' dataspace + + ! Create attribute + CALL h5acreate_f(dataset, "null attr", H5T_NATIVE_INTEGER, null_sid, attr, error) + CALL check("h5acreate_f",error,total_error) + + ! Try to read data from the attribute + ! (shouldn't fail, but should leave buffer alone) + value(1) = 103 + data_dims(1) = 1 + CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) + CALL check("h5aread_f",error,total_error) + CALL verify("h5aread_f",value(1),103,total_error) + +! Try to read data from the attribute again but +! for a scalar + + value_scalar = 104 + data_dims(1) = 1 + CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value_scalar, data_dims, error) + CALL check("h5aread_f",error,total_error) + CALL verify("h5aread_f",value_scalar,104,total_error) + + CALL h5aget_space_f(attr, attr_sid, error) + CALL check("h5aget_space_f",error,total_error) + + CALL H5Sextent_equal_f(attr_sid, null_sid, equal, error) + CALL check("H5Sextent_equal_f",error,total_error) + CALL verify("H5Sextent_equal_f",equal,.TRUE.,total_error) + + CALL h5aget_storage_size_f(attr, storage_size, error) + CALL check("h5aget_storage_size_f",error,total_error) + CALL verify("h5aget_storage_size_f",INT(storage_size),0,total_error) + + CALL h5aget_info_f(attr, f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_f", error, total_error) + + ! Check the attribute's information + CALL verify("h5aget_info_f.corder",corder,0,total_error) + + CALL verify("h5aget_info_f.cset", cset, H5T_CSET_ASCII_F, total_error) + CALL h5aget_storage_size_f(attr, storage_size, error) + CALL check("h5aget_storage_size_f",error,total_error) + CALL verify("h5aget_info_f.data_size", INT(data_size), INT(storage_size), total_error) + CALL h5aclose_f(attr,error) + CALL check("h5aclose_f",error,total_error) + + CALL H5Sclose_f(attr_sid, error) + CALL check("H5Sclose_f",error,total_error) + + CALL H5Dclose_f(dataset, error) + CALL check("H5Dclose_f", error,total_error) + + + CALL H5Fclose_f(fid, error) + CALL check("H5Fclose_f", error,total_error) + + CALL H5Sclose_f(sid, error) + CALL check("H5Sclose_f", error,total_error) + + CALL H5Sclose_f(null_sid, error) + CALL check("H5Sclose_f", error,total_error) + +END SUBROUTINE test_attr_null_space + + +SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, total_error) + +!*************************************************************** +!** +!** test_attr_create_by_name(): Test basic H5A (attribute) code. +!** Tests creating attributes by name +!** +!*************************************************************** + + IMPLICIT NONE + + INTEGER(SIZE_T), PARAMETER :: NAME_BUF_SIZE = 7 + LOGICAL :: new_format + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + + INTEGER :: max_compact,min_dense,u + CHARACTER (LEN=NAME_BUF_SIZE) :: attrname + CHARACTER(LEN=8) :: dsetname + + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" + INTEGER, PARAMETER :: NUM_DSETS = 3 + + INTEGER :: curr_dset + + INTEGER(HID_T) :: dset1, dset2, dset3 + INTEGER(HID_T) :: my_dataset + INTEGER :: error + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + + CHARACTER(LEN=2) :: chr2 + LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) + INTEGER :: Input1 + INTEGER :: i + + data_dims = 0 + + + ! Create dataspace for dataset & attributes + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create dataset creation property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Query the attribute creation properties + + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + ! Loop over using index for creation order value + DO i = 1, 2 + ! Print appropriate test message + IF(use_index(i))THEN + WRITE(*,*) " - Testing Creating Attributes By Name w/Creation Order Index" + ELSE + WRITE(*,*) " - Testing Creating Attributes By Name w/o Creation Order Index" + ENDIF + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Set attribute creation order tracking & indexing for object + IF(new_format)THEN + + IF(use_index(i))THEN + Input1 = H5P_CRT_ORDER_INDEXED_F + ELSE + Input1 = 0 + ENDIF + + CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) + CALL check("H5Pset_attr_creation_order",error,total_error) + + ENDIF + + ! Create datasets + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f2",error,total_error) + + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f3",error,total_error) + + CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f4",error,total_error) + + + ! Work on all the datasets + + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + dsetname = DSET1_NAME + CASE (1) + my_dataset = dset2 + dsetname = DSET2_NAME + CASE (2) + my_dataset = dset3 + dsetname = DSET3_NAME + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT + + + ! Create attributes, up to limit of compact form + + DO u = 0, max_compact - 1 + ! Create attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + CALL H5Acreate_by_name_f(fid, dsetname, attrname, H5T_NATIVE_INTEGER, sid, & + attr, error, lapl_id=H5P_DEFAULT_F, acpl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) + CALL check("H5Acreate_by_name_f",error,total_error) + + ! Write data into the attribute + + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Verify information for NEW attribute + CALL attr_info_by_idx_check(my_dataset, attrname, INT(u,HSIZE_T), use_index(i), total_error) + ! CALL check("FAILED IN attr_info_by_idx_check",total_error) + ENDDO + + ! Test opening attributes stored compactly + + CALL attr_open_check(fid, dsetname, my_dataset, u, total_error) + + ENDDO + + + ! Work on all the datasets + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + dsetname = DSET1_NAME + CASE (1) + my_dataset = dset2 + dsetname = DSET2_NAME + CASE (2) + my_dataset = dset3 + dsetname = DSET3_NAME + END SELECT + + ! Create more attributes, to push into dense form + DO u = max_compact, max_compact* 2 - 1 + + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL H5Acreate_by_name_f(fid, dsetname, attrname, H5T_NATIVE_INTEGER, sid, & + attr, error, lapl_id=H5P_DEFAULT_F) + CALL check("H5Acreate_by_name",error,total_error) + + ! Write data into the attribute + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ENDDO + + ENDDO + + ! Close Datasets + CALL h5dclose_f(dset1, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset2, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset3, error) + CALL check("h5dclose_f",error,total_error) + + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + ENDDO + + ! Close property list + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f",error,total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_create_by_name + + +SUBROUTINE test_attr_info_by_idx(new_format, fcpl, fapl, total_error) + +!*************************************************************** +!** +!** test_attr_info_by_idx(): Test basic H5A (attribute) code. +!** Tests querying attribute info by index +!** +!*************************************************************** + + IMPLICIT NONE + + LOGICAL :: new_format + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" + INTEGER, PARAMETER :: NUM_DSETS = 3 + + INTEGER :: curr_dset + + INTEGER(HID_T) :: dset1, dset2, dset3 + INTEGER(HID_T) :: my_dataset + INTEGER :: error + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + INTEGER(HSIZE_T) :: n + LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=2) :: chr2 + + INTEGER :: i, j + + INTEGER, DIMENSION(1) :: attr_integer_data + CHARACTER(LEN=7) :: attrname + + INTEGER(SIZE_T) :: size + CHARACTER(LEN=80) :: tmpname + + INTEGER :: Input1 + INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T + INTEGER :: minusone = -1 + INTEGER(HSIZE_T) :: htmp + + data_dims = 0 + + ! Create dataspace for dataset & attributes + + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + + ! Create dataset creation property list + + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + + ! Query the attribute creation properties + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + ! Loop over using index for creation order value + + DO i = 1, 2 + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Set attribute creation order tracking & indexing for object + IF(new_format)THEN + IF(use_index(i))THEN + Input1 = H5P_CRT_ORDER_INDEXED_F + ELSE + Input1 = 0 + ENDIF + CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) + CALL check("H5Pset_attr_creation_order",error,total_error) + ENDIF + + ! Create datasets + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error ) + CALL check("h5dcreate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error ) + CALL check("h5dcreate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error ) + CALL check("h5dcreate_f",error,total_error) + + ! Work on all the datasets + + DO curr_dset = 0,NUM_DSETS-1 + + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + END SELECT + + ! Check for query on non-existant attribute + + n = 0 + + ! -- CHECK PASSING AN INTEGER CONSTANT IN DIFFERENT FORMS -- + + ! 1) call by passing an integer with the _hsize_t declaration + + CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, 0_hsize_t, & + f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) + CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) + + ! 2) call by passing an integer with the INT(,hsize_t) declaration + + CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(0,hsize_t), & + f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) + CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) + + + ! 3) call by passing a variable with the attribute hsize_t + + CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, hzero, & + f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) + CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) + + CALL h5aget_name_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, & + hzero, tmpname, error, size, lapl_id=H5P_DEFAULT_F) + CALL verify("h5aget_name_by_idx_f",error,minusone,total_error) + + + ! Create attributes, up to limit of compact form + + DO j = 0, max_compact-1 + ! Create attribute + WRITE(chr2,'(I2.2)') j + attrname = 'attr '//chr2 + + ! check with the optional information create2 specs. + CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + + attr_integer_data(1) = j + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Verify information for new attribute + +!EP CALL attr_info_by_idx_check(my_dataset, attrname, INT(j,HSIZE_T), use_index(i), total_error ) + htmp = j + CALL attr_info_by_idx_check(my_dataset, attrname, htmp, use_index(i), total_error ) + + !CHECK(ret, FAIL, "attr_info_by_idx_check"); + ENDDO + + ENDDO + + + ! Close Datasets + CALL h5dclose_f(dset1, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset2, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset3, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + END DO + + ! Close property list + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_info_by_idx + + +SUBROUTINE attr_info_by_idx_check(obj_id, attrname, n, use_index, total_error ) + + IMPLICIT NONE + + INTEGER :: error, total_error + + INTEGER(HID_T) :: obj_id + CHARACTER(LEN=*) :: attrname + INTEGER(HSIZE_T) :: n + LOGICAL :: use_index + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + + INTEGER(SIZE_T) :: NAME_BUF_SIZE = 7 + CHARACTER(LEN=7) :: tmpname + INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T + + + ! Verify the information for first attribute, in increasing creation order + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, hzero, & + f_corder_valid, corder, cset, data_size, error) + + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,0,total_error) + ! Verify the information for new attribute, in increasing creation order + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, n, & + f_corder_valid, corder, cset, data_size, error) + + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + ! Verify the name for new link, in increasing creation order + + ! Try with the correct buffer size + + CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, & + n, tmpname, error, NAME_BUF_SIZE) + CALL check("h5aget_name_by_idx_f",error,total_error) + CALL verify("h5aget_name_by_idx_f", INT(NAME_BUF_SIZE), 7, error) + + IF(attrname.NE.tmpname)THEN + error = -1 + ENDIF + CALL verify("h5aget_name_by_idx_f",error,0,total_error) + + ! Don't test "native" order if there is no creation order index, since + ! * there's not a good way to easily predict the attribute's order in the name + ! * index. + ! + IF (use_index) THEN + ! Verify the information for first attribute, in native creation order + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, hzero, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,0,total_error) + + ! Verify the information for new attribute, in native creation order + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, n, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + ! Verify the name for new link, in increasing native order + CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, & + n, tmpname, error) ! check with no optional parameters + CALL check("h5aget_name_by_idx_f",error,total_error) + IF(TRIM(attrname).NE.TRIM(tmpname))THEN + WRITE(*,*) "ERROR: attribute name size wrong!" + error = -1 + ENDIF + CALL verify("h5aget_name_by_idx_f",error,0,total_error) + END IF + + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, n, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,0,total_error) + +!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, 0_HSIZE_T, & + + ! -- CHECK PASSING AN INTEGER CONSTANT IN DIFFERENT FORMS -- + + ! 1) call by passing an integer with the _hsize_t declaration + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, 0_HSIZE_T, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + ! 2) call by passing an integer with the INT(,hsize_t) declaration + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, INT(0,HSIZE_T), & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + ! 3) call by passing a variable with the attribute hsize_t + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, hzero, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + +!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_HSIZE_T, & + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, hzero, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,0,total_error) + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, n, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, n, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,0,total_error) +!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, 0_HSIZE_T, & + CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, hzero, & + f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_by_idx_f",error,total_error) + CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) + + +END SUBROUTINE attr_info_by_idx_check + + +SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error) + +!*************************************************************** +!** +!** test_attr_shared_rename(): Test basic H5A (attribute) code. +!** Tests renaming shared attributes in "compact" & "dense" storage +!** +!*************************************************************** + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid, big_sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + + + INTEGER(HID_T) :: dataset, dataset2 + + INTEGER :: error + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HID_T) :: attr_tid + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=2) :: chr2 + + + INTEGER, DIMENSION(1) :: attr_integer_data + CHARACTER(LEN=7) :: attrname + CHARACTER(LEN=11) :: attrname2 + + INTEGER :: u + INTEGER(HID_T) :: my_fcpl + + CHARACTER(LEN=5), PARAMETER :: TYPE1_NAME = "/Type" + + INTEGER :: test_shared + INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension + INTEGER :: arank = 1 ! Attribure rank + + ! Initialize "big" attribute data + + ! Create dataspace for dataset + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create "big" dataspace for "large" attributes + + CALL h5screate_simple_f(arank, adims2, big_sid, error) + CALL check("h5screate_simple_f",error,total_error) + + ! Loop over type of shared components + DO test_shared = 0, 2 + ! Make copy of file creation property list + CALL H5Pcopy_f(fcpl, my_fcpl, error) + CALL check("H5Pcopy",error,total_error) + + ! Set up datatype for attributes + + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, attr_tid, error) + CALL check("H5Tcopy",error,total_error) + + ! Special setup for each type of shared components + + IF( test_shared .EQ. 0) THEN + ! Make attributes > 500 bytes shared + CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,1,error) + CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) + CALL check(" H5Pset_shared_mesg_index_f",error, total_error) + + ELSE + ! Set up copy of file creation property list + CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,3,error) + + ! Make attributes > 500 bytes shared + CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) + ! Make datatypes & dataspaces > 1 byte shared (i.e. all of them :-) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 1, H5O_SHMESG_DTYPE_FLAG_F, 1,error) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 2, H5O_SHMESG_SDSPACE_FLAG_F, 1,error) + ENDIF + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, my_fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Close FCPL copy + CALL h5pclose_f(my_fcpl, error) + CALL check("h5pclose_f", error, total_error) + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Re-open file + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error,fapl) + CALL check("h5open_f",error,total_error) + + ! Commit datatype to file + IF(test_shared.EQ.2) THEN + CALL H5Tcommit_f(fid, TYPE1_NAME, attr_tid, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("H5Tcommit",error,total_error) + ENDIF + + ! Set up to query the object creation properties + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Create datasets + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dataset2, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + + ! Retrieve limits for compact/dense attribute storage + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + ! Close property list + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + + ! Add attributes to each dataset, until after converting to dense storage + DO u = 0, (max_compact * 2) - 1 + + ! Create attribute name + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + ! Alternate between creating "small" & "big" attributes + + IF(MOD(u+1,2).EQ.0)THEN + ! Create "small" attribute on first dataset + + CALL h5acreate_f(dataset, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ELSE + ! Create "big" attribute on first dataset + + CALL h5acreate_f(dataset, attrname, attr_tid, big_sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + + data_dims(1) = 1 + attr_integer_data(1) = u + 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ENDIF + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Alternate between creating "small" & "big" attributes + IF(MOD(u+1,2).EQ.0)THEN + + ! Create "small" attribute on second dataset + + CALL h5acreate_f(dataset2, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ELSE + + ! Create "big" attribute on second dataset + + CALL h5acreate_f(dataset2, attrname, attr_tid, big_sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + +! Write data into the attribute + + + attr_integer_data(1) = u + 1 + data_dims(1) = 1 +! CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) +! CALL check("h5awrite_f",error,total_error) + + +! Check refcount for attribute + ENDIF + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Create new attribute name + + WRITE(chr2,'(I2.2)') u + attrname2 = 'new attr '//chr2 + + + ! Change second dataset's attribute's name + + CALL H5Arename_by_name_f(fid, DSET2_NAME, attrname, attrname2, error, lapl_id=H5P_DEFAULT_F) + CALL check("H5Arename_by_name_f",error,total_error) + + ! Check refcount on attributes now + + ! Check refcount on renamed attribute + + CALL H5Aopen_f(dataset2, attrname2, attr, error, aapl_id=H5P_DEFAULT_F) + CALL check("H5Aopen_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Check refcount on original attribute + CALL H5Aopen_f(dataset, attrname, attr, error) + CALL check("H5Aopen",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + + ! Change second dataset's attribute's name back to original + + CALL H5Arename_by_name_f(fid, DSET2_NAME, attrname2, attrname, error) + CALL check("H5Arename_by_name_f",error,total_error) + + ! Check refcount on attributes now + + ! Check refcount on renamed attribute + CALL H5Aopen_f(dataset2, attrname, attr, error) + CALL check("H5Aopen",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Check refcount on original attribute + + ! Check refcount on renamed attribute + CALL H5Aopen_f(dataset, attrname, attr, error) + CALL check("H5Aopen",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ENDDO + + ! Close attribute's datatype + CALL h5tclose_f(attr_tid, error) + CALL check("h5tclose_f",error,total_error) + + ! Close attribute's datatype + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dataset2, error) + CALL check("h5dclose_f",error,total_error) + + + ! Unlink datasets with attributes + CALL H5Ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) + CALL check("HLdelete",error,total_error) + CALL H5Ldelete_f(fid, DSET2_NAME, error) + CALL check("HLdelete",error,total_error) + + ! Unlink committed datatype + IF(test_shared == 2)THEN + CALL H5Ldelete_f(fid, TYPE1_NAME, error) + CALL check("HLdelete_f",error,total_error) + ENDIF + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Check size of file + !filesize = h5_get_file_size(FILENAME); + !verify(filesize, empty_filesize, "h5_get_file_size"); + ENDDO + + ! Close dataspaces + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(big_sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_shared_rename + + +SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error) + +!*************************************************************** +!** +!** test_attr_delete_by_idx(): Test basic H5A (attribute) code. +!** Tests deleting attribute by index +!** +!*************************************************************** + + IMPLICIT NONE + + LOGICAL, INTENT(IN) :: new_format + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid ! HDF5 File ID + INTEGER(HID_T) :: dcpl ! Dataset creation property list ID + INTEGER(HID_T) :: sid ! Dataspace ID + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" + INTEGER, PARAMETER :: NUM_DSETS = 3 + + INTEGER :: curr_dset + + INTEGER(HID_T) :: dset1, dset2, dset3 + INTEGER(HID_T) :: my_dataset + + INTEGER :: error + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=2) :: chr2 + + INTEGER :: i + + INTEGER, DIMENSION(1) :: attr_integer_data + CHARACTER(LEN=7) :: attrname + + INTEGER(SIZE_T) :: size + CHARACTER(LEN=8) :: tmpname + + INTEGER :: idx_type + INTEGER :: order + INTEGER :: u ! Local index variable + INTEGER :: Input1 + INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T + INTEGER :: minusone = -1 + + data_dims = 0 + + ! Create dataspace for dataset & attributes + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create dataset creation property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Query the attribute creation properties + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + + ! Loop over operating on different indices on link fields + DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F + + ! Loop over operating in different orders + DO order = H5_ITER_INC_F, H5_ITER_DEC_F + + ! Loop over using index for creation order value + DO i = 1, 2 + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Set attribute creation order tracking & indexing for object + IF(new_format)THEN + + IF(use_index(i))THEN + Input1 = H5P_CRT_ORDER_INDEXED_F + ELSE + Input1 = 0 + ENDIF + + CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) + CALL check("H5Pset_attr_creation_order",error,total_error) + + ENDIF + + ! Create datasets + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl ) + CALL check("h5dcreate_f2",error,total_error) + + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl ) + CALL check("h5dcreate_f3",error,total_error) + + CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl ) + CALL check("h5dcreate_f4",error,total_error) + + ! Work on all the datasets + + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT + + + ! Check for deleting non-existant attribute +!EP CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, 0_HSIZE_T,error, lapl_id=H5P_DEFAULT_F) + CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, hzero,error, lapl_id=H5P_DEFAULT_F) + CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) + + ! Create attributes, up to limit of compact form + DO u = 0, max_compact - 1 + ! Create attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + attr_integer_data(1) = u + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Verify information for new attribute + CALL attr_info_by_idx_check(my_dataset, attrname, INT(u,HSIZE_T), use_index(i), total_error ) + + ENDDO + + ! Check for out of bound deletions + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error, lapl_id=H5P_DEFAULT_F) + CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) + + ENDDO + + + DO curr_dset = 0, NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT + + ! Delete attributes from compact storage + + DO u = 0, max_compact - 2 + + ! Delete first attribute in appropriate order + + +!EP CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, error) + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, hzero, error) + CALL check("H5Adelete_by_idx_f",error,total_error) + + + ! Verify the attribute information for first attribute in appropriate order + ! HDmemset(&ainfo, 0, sizeof(ainfo)); + +!EP CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, & + CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, hzero, & + f_corder_valid, corder, cset, data_size, error) + + IF(new_format)THEN + IF(order.EQ.H5_ITER_INC_F)THEN + CALL verify("H5Aget_info_by_idx_f",corder,u + 1,total_error) + ENDIF + ELSE + CALL verify("H5Aget_info_by_idx_f",corder, max_compact-(u + 2),total_error) + ENDIF + + ! Verify the name for first attribute in appropriate order + + size = 7 ! *CHECK* IF NOT THE SAME SIZE + CALL h5aget_name_by_idx_f(my_dataset, ".", idx_type, order,INT(0,hsize_t), & + tmpname, error, lapl_id=H5P_DEFAULT_F, size=size) + CALL check('h5aget_name_by_idx_f',error,total_error) + IF(order .EQ. H5_ITER_INC_F)THEN + WRITE(chr2,'(I2.2)') u + 1 + attrname = 'attr '//chr2 + ELSE + WRITE(chr2,'(I2.2)') max_compact - (u + 2) + attrname = 'attr '//chr2 + ENDIF + IF(TRIM(attrname).NE.TRIM(tmpname)) error = -1 + CALL verify("h5aget_name_by_idx_f",error,0,total_error) + ENDDO + + ! Delete last attribute + +!EP CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, error) + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, hzero, error) + CALL check("H5Adelete_by_idx_f",error,total_error) + + ENDDO + +! Work on all the datasets + + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT + + ! Create more attributes, to push into dense form + + DO u = 0, (max_compact * 2) - 1 + + ! Create attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + + ! Write data into the attribute + attr_integer_data(1) = u + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + + ENDDO + ! Check for out of bound deletion + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error) + CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) + ENDDO + + ! Work on all the datasets + + DO curr_dset = 0,NUM_DSETS-1 + SELECT CASE (curr_dset) + CASE (0) + my_dataset = dset1 + CASE (1) + my_dataset = dset2 + CASE (2) + my_dataset = dset3 + END SELECT + + ! Delete attributes from dense storage + + DO u = 0, (max_compact * 2) - 1 - 1 + + ! Delete first attribute in appropriate order + + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error) + CALL check("H5Adelete_by_idx_f",error,total_error) + ! Verify the attribute information for first attribute in appropriate order + + CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), & + f_corder_valid, corder, cset, data_size, error) + IF(new_format)THEN + IF(order.EQ.H5_ITER_INC_F)THEN + CALL verify("H5Aget_info_by_idx_f",corder,u + 1,total_error) + ENDIF + ELSE + CALL verify("H5Aget_info_by_idx_f",corder, ((max_compact * 2) - (u + 2)), total_error) + ENDIF + + ! Verify the name for first attribute in appropriate order + ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); + + size = 7 ! *CHECK* if not the correct size + CALL h5aget_name_by_idx_f(my_dataset, ".", idx_type, order,INT(0,hsize_t), & + tmpname, error, size) + + IF(order .EQ. H5_ITER_INC_F)THEN + WRITE(chr2,'(I2.2)') u + 1 + attrname = 'attr '//chr2 + ELSE + WRITE(chr2,'(I2.2)') max_compact * 2 - (u + 2) + attrname = 'attr '//chr2 + ENDIF + IF(TRIM(attrname).NE.TRIM(tmpname)) error = -1 + CALL verify("h5aget_name_by_idx_f",error,0,total_error) + + + ENDDO + ! Delete last attribute + + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error, lapl_id=H5P_DEFAULT_F) + CALL check("H5Adelete_by_idx_f",error,total_error) + + ! Check for deletion on empty attribute storage again + CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error) + CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) + ENDDO + + ! Close Datasets + CALL h5dclose_f(dset1, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset2, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dset3, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + ENDDO + ENDDO + ENDDO + + ! Close property list + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_delete_by_idx + +SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error) + +!*************************************************************** +!** +!** test_attr_shared_delete(): Test basic H5A (attribute) code. +!** Tests deleting shared attributes in "compact" & "dense" storage +!** +!*************************************************************** + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid, big_sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" + + + INTEGER(HID_T) :: dataset, dataset2 + + INTEGER :: error + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HID_T) :: attr_tid + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=2) :: chr2 + + INTEGER, DIMENSION(1) :: attr_integer_data + CHARACTER(LEN=7) :: attrname + + INTEGER :: u + INTEGER(HID_T) :: my_fcpl + + CHARACTER(LEN=5), PARAMETER :: TYPE1_NAME = "/Type" + + INTEGER :: test_shared + INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension + INTEGER :: arank = 1 ! Attribure rank + + ! Output message about test being performed + + ! Initialize "big" attribute DATA + ! Create dataspace for dataset + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create "big" dataspace for "large" attributes + + CALL h5screate_simple_f(arank, adims2, big_sid, error) + CALL check("h5screate_simple_f",error,total_error) + + ! Loop over type of shared components + + DO test_shared = 0, 2 + + ! Make copy of file creation property list + + CALL H5Pcopy_f(fcpl, my_fcpl, error) + CALL check("H5Pcopy",error,total_error) + + ! Set up datatype for attributes + + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, attr_tid, error) + CALL check("H5Tcopy",error,total_error) + + ! Special setup for each type of shared components + IF( test_shared .EQ. 0) THEN + ! Make attributes > 500 bytes shared + CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,1,error) + CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) + CALL check(" H5Pset_shared_mesg_index_f",error, total_error) + + ELSE + ! Set up copy of file creation property list + CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,3,error) + ! Make attributes > 500 bytes shared + CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) + ! Make datatypes & dataspaces > 1 byte shared (i.e. all of them :-) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 1, H5O_SHMESG_DTYPE_FLAG_F, 1,error) + CALL H5Pset_shared_mesg_index_f(my_fcpl, 2, H5O_SHMESG_SDSPACE_FLAG_F, 1,error) + ENDIF + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, my_fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Close FCPL copy + CALL h5pclose_f(my_fcpl, error) + CALL check("h5pclose_f", error, total_error) + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Re-open file + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error,fapl) + CALL check("h5open_f",error,total_error) + + ! Commit datatype to file + + IF(test_shared.EQ.2) THEN + CALL H5Tcommit_f(fid, TYPE1_NAME, attr_tid, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("H5Tcommit",error,total_error) + ENDIF + + ! Set up to query the object creation properties + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Create datasets + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + + CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dataset2, error, dcpl_id=dcpl ) + CALL check("h5dcreate_f",error,total_error) + + ! Retrieve limits for compact/dense attribute storage + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + ! Close property list + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + + ! Add attributes to each dataset, until after converting to dense storage + + DO u = 0, (max_compact * 2) - 1 + + ! Create attribute name + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + ! Alternate between creating "small" & "big" attributes + + IF(MOD(u+1,2).EQ.0)THEN + ! Create "small" attribute on first dataset + + CALL h5acreate_f(dataset, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ELSE + ! Create "big" attribute on first dataset + + CALL h5acreate_f(dataset, attrname, attr_tid, big_sid, attr, error) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ENDIF + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Alternate between creating "small" & "big" attributes + IF(MOD(u+1,2).EQ.0)THEN + + ! Create "small" attribute on second dataset + + CALL h5acreate_f(dataset2, attrname, attr_tid, sid, attr, error) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + ELSE + + ! Create "big" attribute on second dataset + + CALL h5acreate_f(dataset2, attrname, attr_tid, big_sid, attr, error, acpl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + +! Write data into the attribute + + + attr_integer_data(1) = u + 1 + data_dims(1) = 1 + CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ENDIF + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ENDDO + + ! Delete attributes from second dataset + + DO u = 0, max_compact*2-1 + + ! Create attribute name + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + ! Delete second dataset's attribute + CALL H5Adelete_by_name_f(fid, DSET2_NAME, attrname,error,lapl_id=H5P_DEFAULT_F) + CALL check("H5Adelete_by_name", error, total_error) + + CALL h5aopen_f(dataset, attrname, attr, error, aapl_id=H5P_DEFAULT_F) + CALL check("h5aopen_f",error,total_error) + + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + ENDDO + + ! Close attribute's datatype + + CALL h5tclose_f(attr_tid, error) + CALL check("h5tclose_f",error,total_error) + + ! Close Datasets + + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + CALL h5dclose_f(dataset2, error) + CALL check("h5dclose_f",error,total_error) + + ! Unlink datasets WITH attributes + + CALL h5ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) + CALL check("H5Ldelete_f", error, total_error) + CALL h5ldelete_f(fid, DSET2_NAME, error) + CALL check("H5Ldelete_f", error, total_error) + + ! Unlink committed datatype + + IF( test_shared == 2) THEN + CALL h5ldelete_f(fid, TYPE1_NAME, error) + CALL check("H5Ldelete_f", error, total_error) + ENDIF + + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ENDDO + + ! Close dataspaces + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(big_sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_shared_delete + + + +SUBROUTINE test_attr_dense_open( fcpl, fapl, total_error) + +!*************************************************************** +!** +!** test_attr_dense_open(): Test basic H5A (attribute) code. +!** Tests opening attributes in "dense" storage +!** +!*************************************************************** + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + + INTEGER :: error + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=2) :: chr2 + + + CHARACTER(LEN=7) :: attrname + + INTEGER(HID_T) :: dataset + INTEGER :: u + + data_dims = 0 + + + ! Create file + + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + + + ! Re-open file + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) + CALL check("h5open_f",error,total_error) + + ! Create dataspace for dataset + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Query the group creation properties + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Enable creation order tracking on attributes, so creation order tests work + CALL H5Pset_attr_creation_order_f(dcpl, H5P_CRT_ORDER_TRACKED_F, error) + CALL check("H5Pset_attr_creation_order",error,total_error) + + ! Create a dataset + + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, & + lcpl_id=H5P_DEFAULT_F, dcpl_id=dcpl, dapl_id=H5P_DEFAULT_F) + CALL check("h5dcreate_f",error,total_error) + + ! Retrieve limits for compact/dense attribute storage + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f",error,total_error) + + ! Close property list + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f",error,total_error) + + ! Add attributes, until just before converting to dense storage + + DO u = 0, max_compact - 1 + ! Create attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5acreate_f(dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, aapl_id=H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Verify attributes written so far + CALL test_attr_dense_verify(dataset, u, total_error) + ENDDO +! +! Add one more attribute, to push into "dense" storage +! Create attribute + + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5acreate_f(dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, aapl_id=H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write data into the attribute + data_dims(1) = 1 + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + + ! Verify all the attributes written + ! ret = test_attr_dense_verify(dataset, (u + 1)); + ! CHECK(ret, FAIL, "test_attr_dense_verify"); + + ! CLOSE Dataset + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + + ! Unlink dataset with attributes + CALL h5ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) + CALL check("H5Ldelete_f", error, total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Check size of file + ! filesize = h5_get_file_size(FILENAME); + ! verify(filesize, empty_filesize, "h5_get_file_size") + +END SUBROUTINE test_attr_dense_open + +!*************************************************************** +!** +!** test_attr_dense_verify(): Test basic H5A (attribute) code. +!** Verify attributes on object +!** +!*************************************************************** + +SUBROUTINE test_attr_dense_verify(loc_id, max_attr, total_error) + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: loc_id + INTEGER, INTENT(IN) :: max_attr + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(SIZE_T), PARAMETER :: ATTR_NAME_LEN = 8 ! FIX, why if 7 does not work? + + INTEGER :: u + CHARACTER(LEN=2) :: chr2 + CHARACTER(LEN=ATTR_NAME_LEN) :: attrname + CHARACTER(LEN=ATTR_NAME_LEN) :: check_name + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + INTEGER(HID_T) :: attr !String Attribute identifier + INTEGER :: error + INTEGER :: value + + data_dims = 0 + + + ! Retrieve the current # of reported errors + ! old_nerrs = GetTestNumErrs(); + + ! Re-open all the attributes by name and verify the data + + DO u = 0, max_attr -1 + + ! Open attribute + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL h5aopen_f(loc_id, attrname, attr, error) + CALL check("h5aopen_f",error,total_error) + + ! Read data from the attribute + +! value = 103 + data_dims(1) = 1 + CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) + + CALL CHECK("H5Aread_F", error, total_error) + CALL verify("H5Aread_F", value, u, total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + ENDDO + + ! Re-open all the attributes by index and verify the data + + DO u=0, max_attr-1 + + + ! Open attribute + + CALL H5Aopen_by_idx_f(loc_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(u,HSIZE_T), & + attr, error, aapl_id=H5P_DEFAULT_F) + + ! Verify Name + + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + CALL H5Aget_name_f(attr, ATTR_NAME_LEN, check_name, error) + CALL check('H5Aget_name',error,total_error) + IF(check_name.NE.attrname) THEN + WRITE(*,*) 'ERROR: attribute name different: attr_name = ',check_name, ', should be ', attrname + total_error = total_error + 1 + ENDIF + ! Read data from the attribute + data_dims(1) = 1 + CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) + CALL CHECK("H5Aread_f", error, total_error) + CALL verify("H5Aread_f", value, u, total_error) + + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + ENDDO + +END SUBROUTINE test_attr_dense_verify + +!*************************************************************** +!** +!** test_attr_corder_create_empty(): Test basic H5A (attribute) code. +!** Tests basic code to create objects with attribute creation order info +!** +!*************************************************************** + +SUBROUTINE test_attr_corder_create_basic( fcpl, fapl, total_error ) + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: dcpl + INTEGER(HID_T) :: sid + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + + INTEGER(HID_T) :: dataset + + INTEGER :: error + + INTEGER :: crt_order_flags + INTEGER :: minusone = -1 + + ! Output message about test being performed +! WRITE(*,*) " - Testing Basic Code for Attributes with Creation Order Info" + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Create dataset creation property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) + CALL check("h5Pcreate_f",error,total_error) + + ! Get creation order indexing on object + CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) + CALL check("H5Pget_attr_creation_order_f",error,total_error) + CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , 0, total_error) + + ! Setting invalid combination of a attribute order creation order indexing on should fail + CALL H5Pset_attr_creation_order_f(dcpl, H5P_CRT_ORDER_INDEXED_F, error) + CALL verify("H5Pset_attr_creation_order_f",error , minusone, total_error) + CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) + CALL check("H5Pget_attr_creation_order_f",error,total_error) + CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , 0, total_error) + + ! Set attribute creation order tracking & indexing for object + CALL h5pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), error) + CALL check("H5Pset_attr_creation_order_f",error,total_error) + + CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) + CALL check("H5Pget_attr_creation_order_f",error,total_error) + CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , & + IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), total_error) + + ! Create dataspace for dataset + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create a dataset + CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, & + lcpl_id=H5P_DEFAULT_F, dapl_id=H5P_DEFAULT_F, dcpl_id=dcpl) + CALL check("h5dcreate_f",error,total_error) + + ! Close dataspace + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + + + ! Close Dataset + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + + ! Close property list + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Re-open file + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) + CALL check("h5open_f",error,total_error) + + ! Open dataset created + CALL h5dopen_f(fid, DSET1_NAME, dataset, error, H5P_DEFAULT_F ) + CALL check("h5dopen_f",error,total_error) + + + ! Retrieve dataset creation property list for group + CALL H5Dget_create_plist_f(dataset, dcpl, error) + CALL check("H5Dget_create_plist_f",error,total_error) + + ! Query the attribute creation properties + CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) + CALL check("H5Pget_attr_creation_order_f",error,total_error) + CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , & + IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), total_error ) + + ! Close property list + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f",error,total_error) + + ! Close Dataset + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + +END SUBROUTINE test_attr_corder_create_basic + +!*************************************************************** +!** +!** test_attr_basic_write(): Test basic H5A (attribute) code. +!** Tests integer attributes on both datasets and groups +!** +!*************************************************************** + +SUBROUTINE test_attr_basic_write(fapl, total_error) + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid1 + INTEGER(HID_T) :: sid1, sid2 + + CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" + + INTEGER(HID_T) :: dataset + INTEGER :: i + INTEGER :: error + + INTEGER(HID_T) :: attr,attr2 !String Attribute identifier + INTEGER(HID_T) :: group + + CHARACTER(LEN=25) :: check_name + CHARACTER(LEN=18) :: chr_exact_size + + CHARACTER(LEN=5), PARAMETER :: ATTR1_NAME="Attr1" + INTEGER, PARAMETER :: ATTR1_RANK = 1 + INTEGER, PARAMETER :: ATTR1_DIM1 = 3 + CHARACTER(LEN=7), PARAMETER :: ATTR1A_NAME ="Attr1_a" + CHARACTER(LEN=18), PARAMETER :: ATTR_TMP_NAME = "Attr1_a-1234567890" + INTEGER, DIMENSION(ATTR1_DIM1) :: attr_data1 + INTEGER, DIMENSION(ATTR1_DIM1) :: attr_data1a + INTEGER, DIMENSION(ATTR1_DIM1) :: read_data1 + INTEGER(HSIZE_T) :: attr_size ! attributes storage requirements .MSB. + INTEGER(HSIZE_T), DIMENSION(1) :: dimsa = (/3/) ! Dataset dimensions + + INTEGER :: rank1 = 2 ! Dataspace1 rank + INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/4,6/) ! Dataset dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: maxdims1 = (/4,6/) ! maximum dimensions + + INTEGER(SIZE_T) :: size + +!! Initialize attribute data + attr_data1(1) = 258 + attr_data1(2) = 9987 + attr_data1(3) = -99890 + + attr_data1a(1) = 258 + attr_data1a(2) = 1087 + attr_data1a(3) = -99890 + + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid1, error, H5P_DEFAULT_F, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Create dataspace for dataset + CALL h5screate_simple_f(rank1, dims1, sid1, error, maxdims1) + CALL check("h5screate_simple_f",error,total_error) + + ! Create a dataset + CALL h5dcreate_f(fid1, DSET1_NAME, H5T_NATIVE_CHARACTER, sid1, dataset, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F ) + CALL check("h5dcreate_f",error,total_error) + + ! Create dataspace for attribute + CALL h5screate_simple_f(ATTR1_RANK, dimsa, sid2, error) + CALL check("h5screate_simple_f",error,total_error) + + ! Try to create an attribute on the file (should create an attribute on root group) + CALL h5acreate_f(fid1, ATTR1_NAME, H5T_NATIVE_INTEGER, sid2, attr, error, aapl_id=H5P_DEFAULT_F, acpl_id=H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Open the root group + CALL H5Gopen_f(fid1, "/", group, error, H5P_DEFAULT_F) + CALL check("H5Gopen_f",error,total_error) + + ! Open attribute again + CALL h5aopen_f(group, ATTR1_NAME, attr, error) + CALL check("h5aopen_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Close root group + CALL H5Gclose_f(group, error) + CALL check("h5gclose_f",error,total_error) + + ! Create an attribute for the dataset + CALL h5acreate_f(dataset, ATTR1_NAME, H5T_NATIVE_INTEGER, sid2, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write attribute information + + CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_data1, dimsa, error) + CALL check("h5awrite_f",error,total_error) + + ! Create an another attribute for the dataset + CALL h5acreate_f(dataset, ATTR1A_NAME, H5T_NATIVE_INTEGER, sid2, attr2, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + ! Write attribute information + CALL h5awrite_f(attr2, H5T_NATIVE_INTEGER, attr_data1a, dimsa, error) + CALL check("h5awrite_f",error,total_error) + + ! Check storage size for attribute + + CALL h5aget_storage_size_f(attr, attr_size, error) + CALL check("h5aget_storage_size_f",error,total_error) +!EP CALL verify("h5aget_storage_size_f", INT(attr_size), 2*HSIZE_T, total_error) + + + ! Read attribute information immediately, without closing attribute + CALL h5aread_f(attr, H5T_NATIVE_INTEGER, read_data1, dimsa, error) + CALL check("h5aread_f",error,total_error) + + ! Verify values read in + DO i = 1, ATTR1_DIM1 + CALL verify('h5aread_f',attr_data1(i),read_data1(i), total_error) + ENDDO + + ! CLOSE attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! Close attribute + CALL h5aclose_f(attr2, error) + CALL check("h5aclose_f",error,total_error) + + ! change attribute name + CALL H5Arename_f(dataset, ATTR1_NAME, ATTR_TMP_NAME, error) + CALL check("H5Arename_f", error, total_error) + + ! Open attribute again + + CALL h5aopen_f(dataset, ATTR_TMP_NAME, attr, error) + CALL check("h5aopen_f",error,total_error) + + ! Verify new attribute name + ! Set a deliberately small size + + check_name = ' ' ! need to initialize or does not pass test + + size = 1 + CALL H5Aget_name_f(attr, size, check_name, error) + CALL check('H5Aget_name',error,total_error) + + ! Now enter with the corrected size + IF(error.NE.size)THEN + size = error + CALL H5Aget_name_f(attr, size, check_name, error) + CALL check('H5Aget_name',error,total_error) + ENDIF + + IF(TRIM(ADJUSTL(check_name)).NE.TRIM(ADJUSTL(ATTR_TMP_NAME))) THEN + PRINT*,'.'//TRIM(check_name)//'.',LEN_TRIM(check_name) + PRINT*,'.'//TRIM(ATTR_TMP_NAME)//'.',LEN_TRIM(ATTR_TMP_NAME) + WRITE(*,*) 'ERROR: attribute name different: attr_name ='//TRIM(check_name)//'.' + WRITE(*,*) ' should be ='//TRIM(ATTR_TMP_NAME)//'.' + total_error = total_error + 1 + stop + ENDIF + + ! Try with a string buffer that is exactly the correct size + size = 18 + CALL H5Aget_name_f(attr, size, chr_exact_size, error) + CALL check('H5Aget_name_f',error,total_error) + CALL verify('H5Aget_name_f',chr_exact_size,ATTR_TMP_NAME, total_error) + + ! Close attribute + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + CALL h5sclose_f(sid1, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(sid2, error) + CALL check("h5sclose_f",error,total_error) + ! Close Dataset + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid1, error) + CALL check("h5fclose_f",error,total_error) + +END SUBROUTINE test_attr_basic_write + +!*************************************************************** +!** +!** test_attr_many(): Test basic H5A (attribute) code. +!** Tests storing lots of attributes +!** +!*************************************************************** + +SUBROUTINE test_attr_many(new_format, fcpl, fapl, total_error) + + IMPLICIT NONE + + LOGICAL, INTENT(IN) :: new_format + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + CHARACTER(LEN=8) :: FileName = "tattr.h5" + INTEGER(HID_T) :: fid + INTEGER(HID_T) :: sid + INTEGER(HID_T) :: gid + INTEGER(HID_T) :: aid + INTEGER :: error + + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + CHARACTER(LEN=5) :: chr5 + + + CHARACTER(LEN=11) :: attrname + CHARACTER(LEN=8), PARAMETER :: GROUP1_NAME="/Group1" + + INTEGER :: u + INTEGER :: nattr + LOGICAL :: exists + INTEGER, DIMENSION(1) :: attr_data1 + + data_dims = 0 + + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Create dataspace for attribute + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create group for attributes + + CALL H5Gcreate_f(fid, GROUP1_NAME, gid, error) + CALL check("H5Gcreate_f", error, total_error) + + ! Create many attributes + + IF(new_format)THEN + nattr = 250 + ELSE + nattr = 2 + ENDIF + + DO u = 0, nattr - 1 + + WRITE(chr5,'(I5.5)') u + attrname = 'attr '//chr5 + CALL H5Aexists_f( gid, attrname, exists, error) + CALL verify("H5Aexists",exists,.FALSE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error, lapl_id = H5P_DEFAULT_F) + CALL verify("H5Aexists_by_name_f",exists,.FALSE.,total_error ) + + CALL h5acreate_f(gid, attrname, H5T_NATIVE_INTEGER, sid, aid, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5acreate_f",error,total_error) + + CALL H5Aexists_f(gid, attrname, exists, error) + CALL verify("H5Aexists",exists,.TRUE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) + CALL verify("H5Aexists_by_name_f",exists,.TRUE.,total_error ) + + attr_data1(1) = u + data_dims(1) = 1 + + CALL h5awrite_f(aid, H5T_NATIVE_INTEGER, attr_data1, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + CALL h5aclose_f(aid, error) + CALL check("h5aclose_f",error,total_error) + + CALL H5Aexists_f(gid, attrname, exists, error) + CALL verify("H5Aexists",exists,.TRUE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) + CALL verify("H5Aexists_by_name_f",exists,.TRUE.,total_error ) + + ENDDO + + ! Close group + CALL H5Gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + + ! Close file + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Close dataspaces + CALL h5sclose_f(sid, error) + CALL check("h5sclose_f",error,total_error) + +END SUBROUTINE test_attr_many + +!------------------------------------------------------------------------- +! * Function: attr_open_check +! * +! * Purpose: Check opening attribute on an object +! * +! * Return: Success: 0 +! * Failure: -1 +! * +! * Programmer: Fortran version (M.S. Breitenfeld) +! * March 21, 2008 +! * +! *------------------------------------------------------------------------- +! + +SUBROUTINE attr_open_check(fid, dsetname, obj_id, max_attrs, total_error ) + + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: fid + CHARACTER(LEN=*), INTENT(IN) :: dsetname + INTEGER(HID_T), INTENT(IN) :: obj_id + INTEGER, INTENT(IN) :: max_attrs + INTEGER, INTENT(INOUT) :: total_error + + INTEGER :: u + CHARACTER (LEN=8) :: attrname + INTEGER :: error + LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters + + INTEGER(HSIZE_T) :: storage_size ! attributes storage requirements + CHARACTER(LEN=2) :: chr2 + INTEGER(HID_T) attr_id + ! Open each attribute on object by index and check that it's the correct one + + DO u = 0, max_attrs-1 + ! Open the attribute + + WRITE(chr2,'(I2.2)') u + attrname = 'attr '//chr2 + + + CALL h5aopen_f(obj_id, attrname, attr_id, error) + CALL check("h5aopen_f",error,total_error) + + + ! Get the attribute's information + + CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_f",error,total_error) + + ! Check that the object's attributes are correct + CALL verify("h5aget_info_f.corder",corder,u,total_error) + CALL verify("h5aget_info_f.corder_valid",f_corder_valid,.TRUE.,total_error) + CALL verify("h5aget_info_f.cset", cset, H5T_CSET_ASCII_F, total_error) + CALL h5aget_storage_size_f(attr_id, storage_size, error) + CALL check("h5aget_storage_size_f",error,total_error) + + CALL verify("h5aget_info_f.data_size", INT(data_size), INT(storage_size), total_error) + + + ! Close attribute + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + + ! Open the attribute + + CALL H5Aopen_by_name_f(obj_id, ".", attrname, attr_id, error, lapl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) + CALL check("H5Aopen_by_name_f", error, total_error) + + CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_f",error,total_error) + ! Check the attribute's information + CALL verify("h5aget_info_f",corder,u,total_error) + CALL verify("h5aget_info_f",f_corder_valid,.TRUE.,total_error) + CALL verify("h5aget_info_f", cset, H5T_CSET_ASCII_F, total_error) + CALL h5aget_storage_size_f(attr_id, storage_size, error) + CALL check("h5aget_storage_size_f",error,total_error) + CALL verify("h5aget_info_f", INT(data_size), INT(storage_size), total_error) + + ! Close attribute + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + + + ! Open the attribute + CALL H5Aopen_by_name_f(fid, dsetname, attrname, attr_id, error) + CALL check("H5Aopen_by_name_f", error, total_error) + + + ! Get the attribute's information + CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) + CALL check("h5aget_info_f",error,total_error) + + ! Check the attribute's information + CALL verify("h5aget_info_f",corder,u,total_error) + CALL verify("h5aget_info_f",f_corder_valid,.TRUE.,total_error) + CALL verify("h5aget_info_f", cset, H5T_CSET_ASCII_F, total_error) + CALL h5aget_storage_size_f(attr_id, storage_size, error) + CALL check("h5aget_storage_size_f",error,total_error) + CALL verify("h5aget_info_f", INT(data_size), INT(storage_size), total_error) + + ! Close attribute + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + ENDDO + +END SUBROUTINE attr_open_check +END MODULE TH5A_1_8 diff --git a/fortran/test/tH5A_1_8.f90 b/fortran/test/tH5A_1_8.f90 deleted file mode 100644 index c70e288..0000000 --- a/fortran/test/tH5A_1_8.f90 +++ /dev/null @@ -1,2779 +0,0 @@ -!****h* root/fortran/test/tH5A_1_8.f90 -! -! NAME -! tH5A_1_8.f90 -! -! FUNCTION -! Basic testing of Fortran H5A APIs introduced in 1.8. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! attribute_test_1_8, test_attr_corder_create_compact, test_attr_null_space, -! test_attr_create_by_name, test_attr_info_by_idx, attr_info_by_idx_check, -! test_attr_shared_rename, test_attr_delete_by_idx, test_attr_shared_delete, -! test_attr_dense_open, test_attr_dense_verify, test_attr_corder_create_basic, -! test_attr_basic_write, test_attr_many, attr_open_check, -! -!***** -MODULE TH5A_1_8 - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS -SUBROUTINE attribute_test_1_8(cleanup, total_error) - -! This subroutine tests following 1.8 functionalities: -! h5acreate_f, h5awrite_f, h5aclose_f,h5aread_f, h5aopen_name_f, -! h5aget_name_f,h5aget_space_f, h5aget_type_f, H5Pset_shared_mesg_nindexes_f, -! H5Pset_shared_mesg_index_f -! - - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - ! - !general purpose integer - ! - INTEGER :: i, j - INTEGER :: error ! Error flag - - ! NEW STARTS HERE - INTEGER(HID_T) :: fapl = -1, fapl2 = -1 - INTEGER(HID_T) :: fcpl = -1, fcpl2 = -1 - INTEGER(HID_T) :: my_fapl, my_fcpl - LOGICAL, DIMENSION(1:2) :: new_format = (/.TRUE.,.FALSE./) - LOGICAL, DIMENSION(1:2) :: use_shared = (/.TRUE.,.FALSE./) - - INTEGER :: ret_total_error - -! ******************** -! test_attr equivelent -! ******************** - -! WRITE(*,*) "TESTING ATTRIBUTES" - - CALL H5Pcreate_f(H5P_FILE_ACCESS_F,fapl,error) - CALL check("h5Pcreate_f",error,total_error) - CALL h5pcopy_f(fapl, fapl2, error) - CALL check("h5pcopy_f",error,total_error) - - CALL H5Pcreate_f(H5P_FILE_CREATE_F,fcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - CALL h5pcopy_f(fcpl, fcpl2, error) - CALL check("h5pcopy_f",error,total_error) - - CALL H5Pset_shared_mesg_nindexes_f(fcpl2,1,error) - CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) - - CALL H5Pset_shared_mesg_index_f(fcpl2, 0, H5O_SHMESG_ATTR_FLAG_F, 1, error) - CALL check(" H5Pset_shared_mesg_index_f",error, total_error) - - DO i = 1, 2 - - IF (new_format(i)) THEN - WRITE(*,'(1X,A)') "Testing with new file format:" - my_fapl = fapl2 - ELSE - WRITE(*,'(1X,A)') "Testing with old file format:" - my_fapl = fapl - END IF - ret_total_error = 0 - CALL test_attr_basic_write(my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Tests INT attributes on both datasets and groups', & - total_error) - - IF(new_format(i)) THEN - DO j = 1, 2 - IF (use_shared(j)) THEN - WRITE(*,*) " - Testing with shared attributes:" - my_fcpl = fcpl2 - ELSE - WRITE(*,*) " - Testing without shared attributes:" - my_fcpl = fcpl - END IF - - ret_total_error = 0 - CALL test_attr_dense_open(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing INT attributes on both datasets and groups', & - total_error) - - ret_total_error = 0 - CALL test_attr_null_space(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing storing attribute with "null" dataspace', & - total_error) - ret_total_error = 0 - CALL test_attr_many(new_format(i), my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing storing lots of attributes', & - total_error) - - ret_total_error = 0 - CALL test_attr_corder_create_basic(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing creating objects with attribute creation order', & - total_error) - - ret_total_error = 0 - CALL test_attr_corder_create_compact(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing compact storage on objects with attribute creation order', & - total_error) - ret_total_error = 0 - CALL test_attr_info_by_idx(new_format(i), my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing querying attribute info by index', & - total_error) - - ret_total_error = 0 - CALL test_attr_delete_by_idx(new_format(i), my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing deleting attribute by index', & - total_error) - - ret_total_error = 0 - CALL test_attr_create_by_name(new_format(i), my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' - Testing creating attributes by name', & - total_error) - - ! More complex tests with both "new format" and "shared" attributes - IF( use_shared(j) ) THEN - ret_total_error = 0 - CALL test_attr_shared_rename(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error,& - ' - Testing renaming shared attributes in "compact" & "dense" storage', & - total_error) - - ret_total_error = 0 - CALL test_attr_shared_delete(my_fcpl, my_fapl, ret_total_error) - CALL write_test_status(ret_total_error,& - ' - Testing deleting shared attributes in "compact" & "dense" storage', & - total_error) - - END IF - END DO - END IF - ENDDO - - CALL H5Pclose_f(fcpl, error) - CALL CHECK("H5Pclose", error,total_error) - CALL H5Pclose_f(fcpl2, error) - CALL CHECK("H5Pclose", error,total_error) - - IF(cleanup) CALL h5_cleanup_f("tattr", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - - RETURN -END SUBROUTINE attribute_test_1_8 - -SUBROUTINE test_attr_corder_create_compact(fcpl,fapl, total_error) - -!*************************************************************** -!** -!** test_attr_corder_create_compact(): Test basic H5A (attribute) code. -!** Tests compact attribute storage on objects with attribute creation order info -!** -!*************************************************************** - -! Needed for get_info_by_name - - - IMPLICIT NONE - -! - - - arg types - - - - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid - - INTEGER :: error - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" - INTEGER, PARAMETER :: NUM_DSETS = 3 - - INTEGER :: curr_dset - - INTEGER(HID_T) :: dset1, dset2, dset3 - INTEGER(HID_T) :: my_dataset - - INTEGER :: u - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=7) :: attrname - CHARACTER(LEN=2) :: chr2 - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - - data_dims = 0 - -! WRITE(*,*) " - Testing Compact Storage of Attributes with Creation Order Info" - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - ! Create dataset creation property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), error) - CALL check("H5Pset_attr_creation_order",error,total_error) - - ! Query the attribute creation properties - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl ) - CALL check("h5dcreate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - END SELECT - DO u = 0, max_compact - 1 - ! Create attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error) - CALL check("h5acreate_f",error,total_error) - - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - END DO - END DO - - ! Close Datasets - CALL h5dclose_f(dset1, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset2, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset3, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - - ! Close property list - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f",error,total_error) - - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) - CALL check("h5open_f",error,total_error) - - CALL h5dopen_f(fid, DSET1_NAME, dset1, error) - CALL check("h5dopen_f",error,total_error) - CALL h5dopen_f(fid, DSET2_NAME, dset2, error) - CALL check("h5dopen_f",error,total_error) - CALL h5dopen_f(fid, DSET3_NAME, dset3, error) - CALL check("h5dopen_f",error,total_error) - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - CASE DEFAULT - WRITE(*,*) " WARNING: To many data sets! " - END SELECT - DO u = 0,max_compact-1 - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - ! Retrieve information for attribute - - CALL H5Aget_info_by_name_f(my_dataset, ".", attrname, & - f_corder_valid, corder, cset, data_size, error, lapl_id = H5P_DEFAULT_F ) !with optional - - CALL check("H5Aget_info_by_name_f", error, total_error) - - ! Verify creation order of attribute - - CALL verify("H5Aget_info_by_name_f", f_corder_valid, .TRUE., total_error) - CALL verify("H5Aget_info_by_name_f", corder, u, total_error) - - - ! Retrieve information for attribute - - CALL H5Aget_info_by_name_f(my_dataset, ".", attrname, & - f_corder_valid, corder, cset, data_size, error) ! without optional - - CALL check("H5Aget_info_by_name_f", error, total_error) - - ! Verify creation order of attribute - - CALL verify("H5Aget_info_by_name_f", f_corder_valid, .TRUE., total_error) - CALL verify("H5Aget_info_by_name_f", corder, u, total_error) - - END DO - END DO - ! Close Datasets - CALL h5dclose_f(dset1, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset2, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset3, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - -END SUBROUTINE test_attr_corder_create_compact - -SUBROUTINE test_attr_null_space(fcpl, fapl, total_error) -!*************************************************************** -!** -!** test_attr_null_space(): Test basic H5A (attribute) code. -!** Tests storing attribute with "null" dataspace -!** -!*************************************************************** - - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: sid, null_sid - INTEGER(HID_T) :: dataset - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - - INTEGER :: error - - INTEGER :: value_scalar - INTEGER, DIMENSION(1) :: value - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HID_T) :: attr_sid - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - INTEGER(HSIZE_T) :: storage_size ! attributes storage requirements - - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - - LOGICAL :: equal - - ! test: H5Sextent_equal_f - - data_dims = 0 - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Re-open file - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error) - CALL check("h5open_f",error,total_error) - ! Create dataspace for dataset attributes - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - ! Create "null" dataspace for attribute - CALL h5screate_f(H5S_NULL_F, null_sid, error) - CALL check("h5screate_f",error,total_error) - ! Create a dataset - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error) - CALL check("h5dcreate_f",error,total_error) - ! Add attribute with 'null' dataspace - - ! Create attribute - CALL h5acreate_f(dataset, "null attr", H5T_NATIVE_INTEGER, null_sid, attr, error) - CALL check("h5acreate_f",error,total_error) - - ! Try to read data from the attribute - ! (shouldn't fail, but should leave buffer alone) - value(1) = 103 - data_dims(1) = 1 - CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) - CALL check("h5aread_f",error,total_error) - CALL verify("h5aread_f",value(1),103,total_error) - -! Try to read data from the attribute again but -! for a scalar - - value_scalar = 104 - data_dims(1) = 1 - CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value_scalar, data_dims, error) - CALL check("h5aread_f",error,total_error) - CALL verify("h5aread_f",value_scalar,104,total_error) - - CALL h5aget_space_f(attr, attr_sid, error) - CALL check("h5aget_space_f",error,total_error) - - CALL H5Sextent_equal_f(attr_sid, null_sid, equal, error) - CALL check("H5Sextent_equal_f",error,total_error) - CALL verify("H5Sextent_equal_f",equal,.TRUE.,total_error) - - CALL h5aget_storage_size_f(attr, storage_size, error) - CALL check("h5aget_storage_size_f",error,total_error) - CALL verify("h5aget_storage_size_f",INT(storage_size),0,total_error) - - CALL h5aget_info_f(attr, f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_f", error, total_error) - - ! Check the attribute's information - CALL verify("h5aget_info_f.corder",corder,0,total_error) - - CALL verify("h5aget_info_f.cset", cset, H5T_CSET_ASCII_F, total_error) - CALL h5aget_storage_size_f(attr, storage_size, error) - CALL check("h5aget_storage_size_f",error,total_error) - CALL verify("h5aget_info_f.data_size", INT(data_size), INT(storage_size), total_error) - CALL h5aclose_f(attr,error) - CALL check("h5aclose_f",error,total_error) - - CALL H5Sclose_f(attr_sid, error) - CALL check("H5Sclose_f",error,total_error) - - CALL H5Dclose_f(dataset, error) - CALL check("H5Dclose_f", error,total_error) - - - CALL H5Fclose_f(fid, error) - CALL check("H5Fclose_f", error,total_error) - - CALL H5Sclose_f(sid, error) - CALL check("H5Sclose_f", error,total_error) - - CALL H5Sclose_f(null_sid, error) - CALL check("H5Sclose_f", error,total_error) - -END SUBROUTINE test_attr_null_space - - -SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, total_error) - -!*************************************************************** -!** -!** test_attr_create_by_name(): Test basic H5A (attribute) code. -!** Tests creating attributes by name -!** -!*************************************************************** - - IMPLICIT NONE - - INTEGER(SIZE_T), PARAMETER :: NAME_BUF_SIZE = 7 - LOGICAL :: new_format - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - - INTEGER :: max_compact,min_dense,u - CHARACTER (LEN=NAME_BUF_SIZE) :: attrname - CHARACTER(LEN=8) :: dsetname - - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" - INTEGER, PARAMETER :: NUM_DSETS = 3 - - INTEGER :: curr_dset - - INTEGER(HID_T) :: dset1, dset2, dset3 - INTEGER(HID_T) :: my_dataset - INTEGER :: error - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - - CHARACTER(LEN=2) :: chr2 - LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) - INTEGER :: Input1 - INTEGER :: i - - data_dims = 0 - - - ! Create dataspace for dataset & attributes - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create dataset creation property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Query the attribute creation properties - - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - ! Loop over using index for creation order value - DO i = 1, 2 - ! Print appropriate test message - IF(use_index(i))THEN - WRITE(*,*) " - Testing Creating Attributes By Name w/Creation Order Index" - ELSE - WRITE(*,*) " - Testing Creating Attributes By Name w/o Creation Order Index" - ENDIF - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Set attribute creation order tracking & indexing for object - IF(new_format)THEN - - IF(use_index(i))THEN - Input1 = H5P_CRT_ORDER_INDEXED_F - ELSE - Input1 = 0 - ENDIF - - CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) - CALL check("H5Pset_attr_creation_order",error,total_error) - - ENDIF - - ! Create datasets - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f2",error,total_error) - - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f3",error,total_error) - - CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f4",error,total_error) - - - ! Work on all the datasets - - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - dsetname = DSET1_NAME - CASE (1) - my_dataset = dset2 - dsetname = DSET2_NAME - CASE (2) - my_dataset = dset3 - dsetname = DSET3_NAME - ! CASE DEFAULT - ! CALL HDassert(0.AND."Toomanydatasets!") - END SELECT - - - ! Create attributes, up to limit of compact form - - DO u = 0, max_compact - 1 - ! Create attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - CALL H5Acreate_by_name_f(fid, dsetname, attrname, H5T_NATIVE_INTEGER, sid, & - attr, error, lapl_id=H5P_DEFAULT_F, acpl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) - CALL check("H5Acreate_by_name_f",error,total_error) - - ! Write data into the attribute - - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Verify information for NEW attribute - CALL attr_info_by_idx_check(my_dataset, attrname, INT(u,HSIZE_T), use_index(i), total_error) - ! CALL check("FAILED IN attr_info_by_idx_check",total_error) - ENDDO - - ! Test opening attributes stored compactly - - CALL attr_open_check(fid, dsetname, my_dataset, u, total_error) - - ENDDO - - - ! Work on all the datasets - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - dsetname = DSET1_NAME - CASE (1) - my_dataset = dset2 - dsetname = DSET2_NAME - CASE (2) - my_dataset = dset3 - dsetname = DSET3_NAME - END SELECT - - ! Create more attributes, to push into dense form - DO u = max_compact, max_compact* 2 - 1 - - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL H5Acreate_by_name_f(fid, dsetname, attrname, H5T_NATIVE_INTEGER, sid, & - attr, error, lapl_id=H5P_DEFAULT_F) - CALL check("H5Acreate_by_name",error,total_error) - - ! Write data into the attribute - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ENDDO - - ENDDO - - ! Close Datasets - CALL h5dclose_f(dset1, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset2, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset3, error) - CALL check("h5dclose_f",error,total_error) - - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - ENDDO - - ! Close property list - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f",error,total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_create_by_name - - -SUBROUTINE test_attr_info_by_idx(new_format, fcpl, fapl, total_error) - -!*************************************************************** -!** -!** test_attr_info_by_idx(): Test basic H5A (attribute) code. -!** Tests querying attribute info by index -!** -!*************************************************************** - - IMPLICIT NONE - - LOGICAL :: new_format - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" - INTEGER, PARAMETER :: NUM_DSETS = 3 - - INTEGER :: curr_dset - - INTEGER(HID_T) :: dset1, dset2, dset3 - INTEGER(HID_T) :: my_dataset - INTEGER :: error - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - INTEGER(HSIZE_T) :: n - LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=2) :: chr2 - - INTEGER :: i, j - - INTEGER, DIMENSION(1) :: attr_integer_data - CHARACTER(LEN=7) :: attrname - - INTEGER(SIZE_T) :: size - CHARACTER(LEN=80) :: tmpname - - INTEGER :: Input1 - INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T - INTEGER :: minusone = -1 - INTEGER(HSIZE_T) :: htmp - - data_dims = 0 - - ! Create dataspace for dataset & attributes - - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - - ! Create dataset creation property list - - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - - ! Query the attribute creation properties - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - ! Loop over using index for creation order value - - DO i = 1, 2 - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Set attribute creation order tracking & indexing for object - IF(new_format)THEN - IF(use_index(i))THEN - Input1 = H5P_CRT_ORDER_INDEXED_F - ELSE - Input1 = 0 - ENDIF - CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) - CALL check("H5Pset_attr_creation_order",error,total_error) - ENDIF - - ! Create datasets - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error ) - CALL check("h5dcreate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error ) - CALL check("h5dcreate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error ) - CALL check("h5dcreate_f",error,total_error) - - ! Work on all the datasets - - DO curr_dset = 0,NUM_DSETS-1 - - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - END SELECT - - ! Check for query on non-existant attribute - - n = 0 - - ! -- CHECK PASSING AN INTEGER CONSTANT IN DIFFERENT FORMS -- - - ! 1) call by passing an integer with the _hsize_t declaration - - CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, 0_hsize_t, & - f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) - CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) - - ! 2) call by passing an integer with the INT(,hsize_t) declaration - - CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(0,hsize_t), & - f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) - CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) - - - ! 3) call by passing a variable with the attribute hsize_t - - CALL h5aget_info_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, hzero, & - f_corder_valid, corder, cset, data_size, error, lapl_id=H5P_DEFAULT_F) - CALL verify("h5aget_info_by_idx_f",error,minusone,total_error) - - CALL h5aget_name_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, & - hzero, tmpname, error, size, lapl_id=H5P_DEFAULT_F) - CALL verify("h5aget_name_by_idx_f",error,minusone,total_error) - - - ! Create attributes, up to limit of compact form - - DO j = 0, max_compact-1 - ! Create attribute - WRITE(chr2,'(I2.2)') j - attrname = 'attr '//chr2 - - ! check with the optional information create2 specs. - CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - - attr_integer_data(1) = j - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Verify information for new attribute - -!EP CALL attr_info_by_idx_check(my_dataset, attrname, INT(j,HSIZE_T), use_index(i), total_error ) - htmp = j - CALL attr_info_by_idx_check(my_dataset, attrname, htmp, use_index(i), total_error ) - - !CHECK(ret, FAIL, "attr_info_by_idx_check"); - ENDDO - - ENDDO - - - ! Close Datasets - CALL h5dclose_f(dset1, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset2, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset3, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - END DO - - ! Close property list - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_info_by_idx - - -SUBROUTINE attr_info_by_idx_check(obj_id, attrname, n, use_index, total_error ) - - IMPLICIT NONE - - INTEGER :: error, total_error - - INTEGER(HID_T) :: obj_id - CHARACTER(LEN=*) :: attrname - INTEGER(HSIZE_T) :: n - LOGICAL :: use_index - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - - INTEGER(SIZE_T) :: NAME_BUF_SIZE = 7 - CHARACTER(LEN=7) :: tmpname - INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T - - - ! Verify the information for first attribute, in increasing creation order - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, hzero, & - f_corder_valid, corder, cset, data_size, error) - - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,0,total_error) - ! Verify the information for new attribute, in increasing creation order - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, n, & - f_corder_valid, corder, cset, data_size, error) - - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - ! Verify the name for new link, in increasing creation order - - ! Try with the correct buffer size - - CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, & - n, tmpname, error, NAME_BUF_SIZE) - CALL check("h5aget_name_by_idx_f",error,total_error) - CALL verify("h5aget_name_by_idx_f", INT(NAME_BUF_SIZE), 7, error) - - IF(attrname.NE.tmpname)THEN - error = -1 - ENDIF - CALL verify("h5aget_name_by_idx_f",error,0,total_error) - - ! Don't test "native" order if there is no creation order index, since - ! * there's not a good way to easily predict the attribute's order in the name - ! * index. - ! - IF (use_index) THEN - ! Verify the information for first attribute, in native creation order - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, hzero, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,0,total_error) - - ! Verify the information for new attribute, in native creation order - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, n, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - ! Verify the name for new link, in increasing native order - CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, & - n, tmpname, error) ! check with no optional parameters - CALL check("h5aget_name_by_idx_f",error,total_error) - IF(TRIM(attrname).NE.TRIM(tmpname))THEN - WRITE(*,*) "ERROR: attribute name size wrong!" - error = -1 - ENDIF - CALL verify("h5aget_name_by_idx_f",error,0,total_error) - END IF - - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, n, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,0,total_error) - -!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, 0_HSIZE_T, & - - ! -- CHECK PASSING AN INTEGER CONSTANT IN DIFFERENT FORMS -- - - ! 1) call by passing an integer with the _hsize_t declaration - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, 0_HSIZE_T, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - ! 2) call by passing an integer with the INT(,hsize_t) declaration - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, INT(0,HSIZE_T), & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - ! 3) call by passing a variable with the attribute hsize_t - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_DEC_F, hzero, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - -!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_HSIZE_T, & - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, hzero, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,0,total_error) - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, n, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, n, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,0,total_error) -!EP CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, 0_HSIZE_T, & - CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, hzero, & - f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_by_idx_f",error,total_error) - CALL verify("h5aget_info_by_idx_f",corder,INT(n),total_error) - - -END SUBROUTINE attr_info_by_idx_check - - -SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error) - -!*************************************************************** -!** -!** test_attr_shared_rename(): Test basic H5A (attribute) code. -!** Tests renaming shared attributes in "compact" & "dense" storage -!** -!*************************************************************** - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid, big_sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - - - INTEGER(HID_T) :: dataset, dataset2 - - INTEGER :: error - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HID_T) :: attr_tid - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=2) :: chr2 - - - INTEGER, DIMENSION(1) :: attr_integer_data - CHARACTER(LEN=7) :: attrname - CHARACTER(LEN=11) :: attrname2 - - INTEGER :: u - INTEGER(HID_T) :: my_fcpl - - CHARACTER(LEN=5), PARAMETER :: TYPE1_NAME = "/Type" - - INTEGER :: test_shared - INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension - INTEGER :: arank = 1 ! Attribure rank - - ! Initialize "big" attribute data - - ! Create dataspace for dataset - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create "big" dataspace for "large" attributes - - CALL h5screate_simple_f(arank, adims2, big_sid, error) - CALL check("h5screate_simple_f",error,total_error) - - ! Loop over type of shared components - DO test_shared = 0, 2 - ! Make copy of file creation property list - CALL H5Pcopy_f(fcpl, my_fcpl, error) - CALL check("H5Pcopy",error,total_error) - - ! Set up datatype for attributes - - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, attr_tid, error) - CALL check("H5Tcopy",error,total_error) - - ! Special setup for each type of shared components - - IF( test_shared .EQ. 0) THEN - ! Make attributes > 500 bytes shared - CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,1,error) - CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) - CALL check(" H5Pset_shared_mesg_index_f",error, total_error) - - ELSE - ! Set up copy of file creation property list - CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,3,error) - - ! Make attributes > 500 bytes shared - CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) - ! Make datatypes & dataspaces > 1 byte shared (i.e. all of them :-) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 1, H5O_SHMESG_DTYPE_FLAG_F, 1,error) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 2, H5O_SHMESG_SDSPACE_FLAG_F, 1,error) - ENDIF - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, my_fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Close FCPL copy - CALL h5pclose_f(my_fcpl, error) - CALL check("h5pclose_f", error, total_error) - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Re-open file - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error,fapl) - CALL check("h5open_f",error,total_error) - - ! Commit datatype to file - IF(test_shared.EQ.2) THEN - CALL H5Tcommit_f(fid, TYPE1_NAME, attr_tid, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("H5Tcommit",error,total_error) - ENDIF - - ! Set up to query the object creation properties - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Create datasets - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dataset2, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - - ! Retrieve limits for compact/dense attribute storage - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - ! Close property list - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - - ! Add attributes to each dataset, until after converting to dense storage - DO u = 0, (max_compact * 2) - 1 - - ! Create attribute name - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - ! Alternate between creating "small" & "big" attributes - - IF(MOD(u+1,2).EQ.0)THEN - ! Create "small" attribute on first dataset - - CALL h5acreate_f(dataset, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ELSE - ! Create "big" attribute on first dataset - - CALL h5acreate_f(dataset, attrname, attr_tid, big_sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - - data_dims(1) = 1 - attr_integer_data(1) = u + 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ENDIF - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Alternate between creating "small" & "big" attributes - IF(MOD(u+1,2).EQ.0)THEN - - ! Create "small" attribute on second dataset - - CALL h5acreate_f(dataset2, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ELSE - - ! Create "big" attribute on second dataset - - CALL h5acreate_f(dataset2, attrname, attr_tid, big_sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - -! Write data into the attribute - - - attr_integer_data(1) = u + 1 - data_dims(1) = 1 -! CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) -! CALL check("h5awrite_f",error,total_error) - - -! Check refcount for attribute - ENDIF - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Create new attribute name - - WRITE(chr2,'(I2.2)') u - attrname2 = 'new attr '//chr2 - - - ! Change second dataset's attribute's name - - CALL H5Arename_by_name_f(fid, DSET2_NAME, attrname, attrname2, error, lapl_id=H5P_DEFAULT_F) - CALL check("H5Arename_by_name_f",error,total_error) - - ! Check refcount on attributes now - - ! Check refcount on renamed attribute - - CALL H5Aopen_f(dataset2, attrname2, attr, error, aapl_id=H5P_DEFAULT_F) - CALL check("H5Aopen_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Check refcount on original attribute - CALL H5Aopen_f(dataset, attrname, attr, error) - CALL check("H5Aopen",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - - ! Change second dataset's attribute's name back to original - - CALL H5Arename_by_name_f(fid, DSET2_NAME, attrname2, attrname, error) - CALL check("H5Arename_by_name_f",error,total_error) - - ! Check refcount on attributes now - - ! Check refcount on renamed attribute - CALL H5Aopen_f(dataset2, attrname, attr, error) - CALL check("H5Aopen",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Check refcount on original attribute - - ! Check refcount on renamed attribute - CALL H5Aopen_f(dataset, attrname, attr, error) - CALL check("H5Aopen",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ENDDO - - ! Close attribute's datatype - CALL h5tclose_f(attr_tid, error) - CALL check("h5tclose_f",error,total_error) - - ! Close attribute's datatype - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dataset2, error) - CALL check("h5dclose_f",error,total_error) - - - ! Unlink datasets with attributes - CALL H5Ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) - CALL check("HLdelete",error,total_error) - CALL H5Ldelete_f(fid, DSET2_NAME, error) - CALL check("HLdelete",error,total_error) - - ! Unlink committed datatype - IF(test_shared == 2)THEN - CALL H5Ldelete_f(fid, TYPE1_NAME, error) - CALL check("HLdelete_f",error,total_error) - ENDIF - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Check size of file - !filesize = h5_get_file_size(FILENAME); - !verify(filesize, empty_filesize, "h5_get_file_size"); - ENDDO - - ! Close dataspaces - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(big_sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_shared_rename - - -SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error) - -!*************************************************************** -!** -!** test_attr_delete_by_idx(): Test basic H5A (attribute) code. -!** Tests deleting attribute by index -!** -!*************************************************************** - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: new_format - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid ! HDF5 File ID - INTEGER(HID_T) :: dcpl ! Dataset creation property list ID - INTEGER(HID_T) :: sid ! Dataspace ID - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - CHARACTER(LEN=8) :: DSET3_NAME = "Dataset3" - INTEGER, PARAMETER :: NUM_DSETS = 3 - - INTEGER :: curr_dset - - INTEGER(HID_T) :: dset1, dset2, dset3 - INTEGER(HID_T) :: my_dataset - - INTEGER :: error - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=2) :: chr2 - - INTEGER :: i - - INTEGER, DIMENSION(1) :: attr_integer_data - CHARACTER(LEN=7) :: attrname - - INTEGER(SIZE_T) :: size - CHARACTER(LEN=8) :: tmpname - - INTEGER :: idx_type - INTEGER :: order - INTEGER :: u ! Local index variable - INTEGER :: Input1 - INTEGER(HSIZE_T) :: hzero = 0_HSIZE_T - INTEGER :: minusone = -1 - - data_dims = 0 - - ! Create dataspace for dataset & attributes - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create dataset creation property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Query the attribute creation properties - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - - ! Loop over operating on different indices on link fields - DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F - - ! Loop over operating in different orders - DO order = H5_ITER_INC_F, H5_ITER_DEC_F - - ! Loop over using index for creation order value - DO i = 1, 2 - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Set attribute creation order tracking & indexing for object - IF(new_format)THEN - - IF(use_index(i))THEN - Input1 = H5P_CRT_ORDER_INDEXED_F - ELSE - Input1 = 0 - ENDIF - - CALL H5Pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) - CALL check("H5Pset_attr_creation_order",error,total_error) - - ENDIF - - ! Create datasets - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dset1, error, dcpl ) - CALL check("h5dcreate_f2",error,total_error) - - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dset2, error, dcpl ) - CALL check("h5dcreate_f3",error,total_error) - - CALL h5dcreate_f(fid, DSET3_NAME, H5T_NATIVE_CHARACTER, sid, dset3, error, dcpl ) - CALL check("h5dcreate_f4",error,total_error) - - ! Work on all the datasets - - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - ! CASE DEFAULT - ! CALL HDassert(0.AND."Toomanydatasets!") - END SELECT - - - ! Check for deleting non-existant attribute -!EP CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, 0_HSIZE_T,error, lapl_id=H5P_DEFAULT_F) - CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, hzero,error, lapl_id=H5P_DEFAULT_F) - CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) - - ! Create attributes, up to limit of compact form - DO u = 0, max_compact - 1 - ! Create attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - attr_integer_data(1) = u - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Verify information for new attribute - CALL attr_info_by_idx_check(my_dataset, attrname, INT(u,HSIZE_T), use_index(i), total_error ) - - ENDDO - - ! Check for out of bound deletions - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error, lapl_id=H5P_DEFAULT_F) - CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) - - ENDDO - - - DO curr_dset = 0, NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - ! CASE DEFAULT - ! CALL HDassert(0.AND."Toomanydatasets!") - END SELECT - - ! Delete attributes from compact storage - - DO u = 0, max_compact - 2 - - ! Delete first attribute in appropriate order - - -!EP CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, error) - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, hzero, error) - CALL check("H5Adelete_by_idx_f",error,total_error) - - - ! Verify the attribute information for first attribute in appropriate order - ! HDmemset(&ainfo, 0, sizeof(ainfo)); - -!EP CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, & - CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, hzero, & - f_corder_valid, corder, cset, data_size, error) - - IF(new_format)THEN - IF(order.EQ.H5_ITER_INC_F)THEN - CALL verify("H5Aget_info_by_idx_f",corder,u + 1,total_error) - ENDIF - ELSE - CALL verify("H5Aget_info_by_idx_f",corder, max_compact-(u + 2),total_error) - ENDIF - - ! Verify the name for first attribute in appropriate order - - size = 7 ! *CHECK* IF NOT THE SAME SIZE - CALL h5aget_name_by_idx_f(my_dataset, ".", idx_type, order,INT(0,hsize_t), & - tmpname, error, lapl_id=H5P_DEFAULT_F, size=size) - CALL check('h5aget_name_by_idx_f',error,total_error) - IF(order .EQ. H5_ITER_INC_F)THEN - WRITE(chr2,'(I2.2)') u + 1 - attrname = 'attr '//chr2 - ELSE - WRITE(chr2,'(I2.2)') max_compact - (u + 2) - attrname = 'attr '//chr2 - ENDIF - IF(TRIM(attrname).NE.TRIM(tmpname)) error = -1 - CALL verify("h5aget_name_by_idx_f",error,0,total_error) - ENDDO - - ! Delete last attribute - -!EP CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, error) - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, hzero, error) - CALL check("H5Adelete_by_idx_f",error,total_error) - - ENDDO - -! Work on all the datasets - - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - ! CASE DEFAULT - ! CALL HDassert(0.AND."Toomanydatasets!") - END SELECT - - ! Create more attributes, to push into dense form - - DO u = 0, (max_compact * 2) - 1 - - ! Create attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5acreate_f(my_dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - - ! Write data into the attribute - attr_integer_data(1) = u - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - - ENDDO - ! Check for out of bound deletion - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error) - CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) - ENDDO - - ! Work on all the datasets - - DO curr_dset = 0,NUM_DSETS-1 - SELECT CASE (curr_dset) - CASE (0) - my_dataset = dset1 - CASE (1) - my_dataset = dset2 - CASE (2) - my_dataset = dset3 - END SELECT - - ! Delete attributes from dense storage - - DO u = 0, (max_compact * 2) - 1 - 1 - - ! Delete first attribute in appropriate order - - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error) - CALL check("H5Adelete_by_idx_f",error,total_error) - ! Verify the attribute information for first attribute in appropriate order - - CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), & - f_corder_valid, corder, cset, data_size, error) - IF(new_format)THEN - IF(order.EQ.H5_ITER_INC_F)THEN - CALL verify("H5Aget_info_by_idx_f",corder,u + 1,total_error) - ENDIF - ELSE - CALL verify("H5Aget_info_by_idx_f",corder, ((max_compact * 2) - (u + 2)), total_error) - ENDIF - - ! Verify the name for first attribute in appropriate order - ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); - - size = 7 ! *CHECK* if not the correct size - CALL h5aget_name_by_idx_f(my_dataset, ".", idx_type, order,INT(0,hsize_t), & - tmpname, error, size) - - IF(order .EQ. H5_ITER_INC_F)THEN - WRITE(chr2,'(I2.2)') u + 1 - attrname = 'attr '//chr2 - ELSE - WRITE(chr2,'(I2.2)') max_compact * 2 - (u + 2) - attrname = 'attr '//chr2 - ENDIF - IF(TRIM(attrname).NE.TRIM(tmpname)) error = -1 - CALL verify("h5aget_name_by_idx_f",error,0,total_error) - - - ENDDO - ! Delete last attribute - - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error, lapl_id=H5P_DEFAULT_F) - CALL check("H5Adelete_by_idx_f",error,total_error) - - ! Check for deletion on empty attribute storage again - CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(0,HSIZE_T), error) - CALL verify("H5Adelete_by_idx_f",error,minusone,total_error) - ENDDO - - ! Close Datasets - CALL h5dclose_f(dset1, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset2, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dset3, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - ENDDO - ENDDO - ENDDO - - ! Close property list - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_delete_by_idx - -SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error) - -!*************************************************************** -!** -!** test_attr_shared_delete(): Test basic H5A (attribute) code. -!** Tests deleting shared attributes in "compact" & "dense" storage -!** -!*************************************************************** - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid, big_sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - CHARACTER(LEN=8) :: DSET2_NAME = "Dataset2" - - - INTEGER(HID_T) :: dataset, dataset2 - - INTEGER :: error - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HID_T) :: attr_tid - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=2) :: chr2 - - INTEGER, DIMENSION(1) :: attr_integer_data - CHARACTER(LEN=7) :: attrname - - INTEGER :: u - INTEGER(HID_T) :: my_fcpl - - CHARACTER(LEN=5), PARAMETER :: TYPE1_NAME = "/Type" - - INTEGER :: test_shared - INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension - INTEGER :: arank = 1 ! Attribure rank - - ! Output message about test being performed - - ! Initialize "big" attribute DATA - ! Create dataspace for dataset - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create "big" dataspace for "large" attributes - - CALL h5screate_simple_f(arank, adims2, big_sid, error) - CALL check("h5screate_simple_f",error,total_error) - - ! Loop over type of shared components - - DO test_shared = 0, 2 - - ! Make copy of file creation property list - - CALL H5Pcopy_f(fcpl, my_fcpl, error) - CALL check("H5Pcopy",error,total_error) - - ! Set up datatype for attributes - - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, attr_tid, error) - CALL check("H5Tcopy",error,total_error) - - ! Special setup for each type of shared components - IF( test_shared .EQ. 0) THEN - ! Make attributes > 500 bytes shared - CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,1,error) - CALL check("H5Pset_shared_mesg_nindexes_f",error, total_error) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) - CALL check(" H5Pset_shared_mesg_index_f",error, total_error) - - ELSE - ! Set up copy of file creation property list - CALL H5Pset_shared_mesg_nindexes_f(my_fcpl,3,error) - ! Make attributes > 500 bytes shared - CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error) - ! Make datatypes & dataspaces > 1 byte shared (i.e. all of them :-) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 1, H5O_SHMESG_DTYPE_FLAG_F, 1,error) - CALL H5Pset_shared_mesg_index_f(my_fcpl, 2, H5O_SHMESG_SDSPACE_FLAG_F, 1,error) - ENDIF - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, my_fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Close FCPL copy - CALL h5pclose_f(my_fcpl, error) - CALL check("h5pclose_f", error, total_error) - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Re-open file - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error,fapl) - CALL check("h5open_f",error,total_error) - - ! Commit datatype to file - - IF(test_shared.EQ.2) THEN - CALL H5Tcommit_f(fid, TYPE1_NAME, attr_tid, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("H5Tcommit",error,total_error) - ENDIF - - ! Set up to query the object creation properties - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Create datasets - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - - CALL h5dcreate_f(fid, DSET2_NAME, H5T_NATIVE_CHARACTER, sid, dataset2, error, dcpl_id=dcpl ) - CALL check("h5dcreate_f",error,total_error) - - ! Retrieve limits for compact/dense attribute storage - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - ! Close property list - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - - ! Add attributes to each dataset, until after converting to dense storage - - DO u = 0, (max_compact * 2) - 1 - - ! Create attribute name - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - ! Alternate between creating "small" & "big" attributes - - IF(MOD(u+1,2).EQ.0)THEN - ! Create "small" attribute on first dataset - - CALL h5acreate_f(dataset, attrname, attr_tid, sid, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ELSE - ! Create "big" attribute on first dataset - - CALL h5acreate_f(dataset, attrname, attr_tid, big_sid, attr, error) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ENDIF - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Alternate between creating "small" & "big" attributes - IF(MOD(u+1,2).EQ.0)THEN - - ! Create "small" attribute on second dataset - - CALL h5acreate_f(dataset2, attrname, attr_tid, sid, attr, error) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - ELSE - - ! Create "big" attribute on second dataset - - CALL h5acreate_f(dataset2, attrname, attr_tid, big_sid, attr, error, acpl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - -! Write data into the attribute - - - attr_integer_data(1) = u + 1 - data_dims(1) = 1 - CALL h5awrite_f(attr, attr_tid, attr_integer_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ENDIF - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ENDDO - - ! Delete attributes from second dataset - - DO u = 0, max_compact*2-1 - - ! Create attribute name - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - ! Delete second dataset's attribute - CALL H5Adelete_by_name_f(fid, DSET2_NAME, attrname,error,lapl_id=H5P_DEFAULT_F) - CALL check("H5Adelete_by_name", error, total_error) - - CALL h5aopen_f(dataset, attrname, attr, error, aapl_id=H5P_DEFAULT_F) - CALL check("h5aopen_f",error,total_error) - - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - ENDDO - - ! Close attribute's datatype - - CALL h5tclose_f(attr_tid, error) - CALL check("h5tclose_f",error,total_error) - - ! Close Datasets - - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - CALL h5dclose_f(dataset2, error) - CALL check("h5dclose_f",error,total_error) - - ! Unlink datasets WITH attributes - - CALL h5ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) - CALL check("H5Ldelete_f", error, total_error) - CALL h5ldelete_f(fid, DSET2_NAME, error) - CALL check("H5Ldelete_f", error, total_error) - - ! Unlink committed datatype - - IF( test_shared == 2) THEN - CALL h5ldelete_f(fid, TYPE1_NAME, error) - CALL check("H5Ldelete_f", error, total_error) - ENDIF - - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ENDDO - - ! Close dataspaces - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(big_sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_shared_delete - - - -SUBROUTINE test_attr_dense_open( fcpl, fapl, total_error) - -!*************************************************************** -!** -!** test_attr_dense_open(): Test basic H5A (attribute) code. -!** Tests opening attributes in "dense" storage -!** -!*************************************************************** - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - - INTEGER :: error - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=2) :: chr2 - - - CHARACTER(LEN=7) :: attrname - - INTEGER(HID_T) :: dataset - INTEGER :: u - - data_dims = 0 - - - ! Create file - - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - - - ! Re-open file - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) - CALL check("h5open_f",error,total_error) - - ! Create dataspace for dataset - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Query the group creation properties - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Enable creation order tracking on attributes, so creation order tests work - CALL H5Pset_attr_creation_order_f(dcpl, H5P_CRT_ORDER_TRACKED_F, error) - CALL check("H5Pset_attr_creation_order",error,total_error) - - ! Create a dataset - - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, & - lcpl_id=H5P_DEFAULT_F, dcpl_id=dcpl, dapl_id=H5P_DEFAULT_F) - CALL check("h5dcreate_f",error,total_error) - - ! Retrieve limits for compact/dense attribute storage - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f",error,total_error) - - ! Close property list - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f",error,total_error) - - ! Add attributes, until just before converting to dense storage - - DO u = 0, max_compact - 1 - ! Create attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5acreate_f(dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, aapl_id=H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Verify attributes written so far - CALL test_attr_dense_verify(dataset, u, total_error) - ENDDO -! -! Add one more attribute, to push into "dense" storage -! Create attribute - - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5acreate_f(dataset, attrname, H5T_NATIVE_INTEGER, sid, attr, error, aapl_id=H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write data into the attribute - data_dims(1) = 1 - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, u, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - - ! Verify all the attributes written - ! ret = test_attr_dense_verify(dataset, (u + 1)); - ! CHECK(ret, FAIL, "test_attr_dense_verify"); - - ! CLOSE Dataset - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - - ! Unlink dataset with attributes - CALL h5ldelete_f(fid, DSET1_NAME, error, H5P_DEFAULT_F) - CALL check("H5Ldelete_f", error, total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Check size of file - ! filesize = h5_get_file_size(FILENAME); - ! verify(filesize, empty_filesize, "h5_get_file_size") - -END SUBROUTINE test_attr_dense_open - -!*************************************************************** -!** -!** test_attr_dense_verify(): Test basic H5A (attribute) code. -!** Verify attributes on object -!** -!*************************************************************** - -SUBROUTINE test_attr_dense_verify(loc_id, max_attr, total_error) - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: loc_id - INTEGER, INTENT(IN) :: max_attr - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(SIZE_T), PARAMETER :: ATTR_NAME_LEN = 8 ! FIX, why if 7 does not work? - - INTEGER :: u - CHARACTER(LEN=2) :: chr2 - CHARACTER(LEN=ATTR_NAME_LEN) :: attrname - CHARACTER(LEN=ATTR_NAME_LEN) :: check_name - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - - INTEGER(HID_T) :: attr !String Attribute identifier - INTEGER :: error - INTEGER :: value - - data_dims = 0 - - - ! Retrieve the current # of reported errors - ! old_nerrs = GetTestNumErrs(); - - ! Re-open all the attributes by name and verify the data - - DO u = 0, max_attr -1 - - ! Open attribute - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL h5aopen_f(loc_id, attrname, attr, error) - CALL check("h5aopen_f",error,total_error) - - ! Read data from the attribute - -! value = 103 - data_dims(1) = 1 - CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) - - CALL CHECK("H5Aread_F", error, total_error) - CALL verify("H5Aread_F", value, u, total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - ENDDO - - ! Re-open all the attributes by index and verify the data - - DO u=0, max_attr-1 - - - ! Open attribute - - CALL H5Aopen_by_idx_f(loc_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(u,HSIZE_T), & - attr, error, aapl_id=H5P_DEFAULT_F) - - ! Verify Name - - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - CALL H5Aget_name_f(attr, ATTR_NAME_LEN, check_name, error) - CALL check('H5Aget_name',error,total_error) - IF(check_name.NE.attrname) THEN - WRITE(*,*) 'ERROR: attribute name different: attr_name = ',check_name, ', should be ', attrname - total_error = total_error + 1 - ENDIF - ! Read data from the attribute - data_dims(1) = 1 - CALL h5aread_f(attr, H5T_NATIVE_INTEGER, value, data_dims, error) - CALL CHECK("H5Aread_f", error, total_error) - CALL verify("H5Aread_f", value, u, total_error) - - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - ENDDO - -END SUBROUTINE test_attr_dense_verify - -!*************************************************************** -!** -!** test_attr_corder_create_empty(): Test basic H5A (attribute) code. -!** Tests basic code to create objects with attribute creation order info -!** -!*************************************************************** - -SUBROUTINE test_attr_corder_create_basic( fcpl, fapl, total_error ) - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: dcpl - INTEGER(HID_T) :: sid - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - - INTEGER(HID_T) :: dataset - - INTEGER :: error - - INTEGER :: crt_order_flags - INTEGER :: minusone = -1 - - ! Output message about test being performed -! WRITE(*,*) " - Testing Basic Code for Attributes with Creation Order Info" - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Create dataset creation property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F,dcpl,error) - CALL check("h5Pcreate_f",error,total_error) - - ! Get creation order indexing on object - CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) - CALL check("H5Pget_attr_creation_order_f",error,total_error) - CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , 0, total_error) - - ! Setting invalid combination of a attribute order creation order indexing on should fail - CALL H5Pset_attr_creation_order_f(dcpl, H5P_CRT_ORDER_INDEXED_F, error) - CALL verify("H5Pset_attr_creation_order_f",error , minusone, total_error) - CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) - CALL check("H5Pget_attr_creation_order_f",error,total_error) - CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , 0, total_error) - - ! Set attribute creation order tracking & indexing for object - CALL h5pset_attr_creation_order_f(dcpl, IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), error) - CALL check("H5Pset_attr_creation_order_f",error,total_error) - - CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) - CALL check("H5Pget_attr_creation_order_f",error,total_error) - CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , & - IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), total_error) - - ! Create dataspace for dataset - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create a dataset - CALL h5dcreate_f(fid, DSET1_NAME, H5T_NATIVE_CHARACTER, sid, dataset, error, & - lcpl_id=H5P_DEFAULT_F, dapl_id=H5P_DEFAULT_F, dcpl_id=dcpl) - CALL check("h5dcreate_f",error,total_error) - - ! Close dataspace - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - - - ! Close Dataset - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - - ! Close property list - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Re-open file - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) - CALL check("h5open_f",error,total_error) - - ! Open dataset created - CALL h5dopen_f(fid, DSET1_NAME, dataset, error, H5P_DEFAULT_F ) - CALL check("h5dopen_f",error,total_error) - - - ! Retrieve dataset creation property list for group - CALL H5Dget_create_plist_f(dataset, dcpl, error) - CALL check("H5Dget_create_plist_f",error,total_error) - - ! Query the attribute creation properties - CALL H5Pget_attr_creation_order_f(dcpl, crt_order_flags, error) - CALL check("H5Pget_attr_creation_order_f",error,total_error) - CALL verify("H5Pget_attr_creation_order_f",crt_order_flags , & - IOR(H5P_CRT_ORDER_TRACKED_F, H5P_CRT_ORDER_INDEXED_F), total_error ) - - ! Close property list - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f",error,total_error) - - ! Close Dataset - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - -END SUBROUTINE test_attr_corder_create_basic - -!*************************************************************** -!** -!** test_attr_basic_write(): Test basic H5A (attribute) code. -!** Tests integer attributes on both datasets and groups -!** -!*************************************************************** - -SUBROUTINE test_attr_basic_write(fapl, total_error) - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid1 - INTEGER(HID_T) :: sid1, sid2 - - CHARACTER(LEN=8) :: DSET1_NAME = "Dataset1" - - INTEGER(HID_T) :: dataset - INTEGER :: i - INTEGER :: error - - INTEGER(HID_T) :: attr,attr2 !String Attribute identifier - INTEGER(HID_T) :: group - - CHARACTER(LEN=25) :: check_name - CHARACTER(LEN=18) :: chr_exact_size - - CHARACTER(LEN=5), PARAMETER :: ATTR1_NAME="Attr1" - INTEGER, PARAMETER :: ATTR1_RANK = 1 - INTEGER, PARAMETER :: ATTR1_DIM1 = 3 - CHARACTER(LEN=7), PARAMETER :: ATTR1A_NAME ="Attr1_a" - CHARACTER(LEN=18), PARAMETER :: ATTR_TMP_NAME = "Attr1_a-1234567890" - INTEGER, DIMENSION(ATTR1_DIM1) :: attr_data1 - INTEGER, DIMENSION(ATTR1_DIM1) :: attr_data1a - INTEGER, DIMENSION(ATTR1_DIM1) :: read_data1 - INTEGER(HSIZE_T) :: attr_size ! attributes storage requirements .MSB. - INTEGER(HSIZE_T), DIMENSION(1) :: dimsa = (/3/) ! Dataset dimensions - - INTEGER :: rank1 = 2 ! Dataspace1 rank - INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/4,6/) ! Dataset dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: maxdims1 = (/4,6/) ! maximum dimensions - - INTEGER(SIZE_T) :: size - -!! Initialize attribute data - attr_data1(1) = 258 - attr_data1(2) = 9987 - attr_data1(3) = -99890 - - attr_data1a(1) = 258 - attr_data1a(2) = 1087 - attr_data1a(3) = -99890 - - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid1, error, H5P_DEFAULT_F, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Create dataspace for dataset - CALL h5screate_simple_f(rank1, dims1, sid1, error, maxdims1) - CALL check("h5screate_simple_f",error,total_error) - - ! Create a dataset - CALL h5dcreate_f(fid1, DSET1_NAME, H5T_NATIVE_CHARACTER, sid1, dataset, error, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F ) - CALL check("h5dcreate_f",error,total_error) - - ! Create dataspace for attribute - CALL h5screate_simple_f(ATTR1_RANK, dimsa, sid2, error) - CALL check("h5screate_simple_f",error,total_error) - - ! Try to create an attribute on the file (should create an attribute on root group) - CALL h5acreate_f(fid1, ATTR1_NAME, H5T_NATIVE_INTEGER, sid2, attr, error, aapl_id=H5P_DEFAULT_F, acpl_id=H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Open the root group - CALL H5Gopen_f(fid1, "/", group, error, H5P_DEFAULT_F) - CALL check("H5Gopen_f",error,total_error) - - ! Open attribute again - CALL h5aopen_f(group, ATTR1_NAME, attr, error) - CALL check("h5aopen_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Close root group - CALL H5Gclose_f(group, error) - CALL check("h5gclose_f",error,total_error) - - ! Create an attribute for the dataset - CALL h5acreate_f(dataset, ATTR1_NAME, H5T_NATIVE_INTEGER, sid2, attr, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write attribute information - - CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_data1, dimsa, error) - CALL check("h5awrite_f",error,total_error) - - ! Create an another attribute for the dataset - CALL h5acreate_f(dataset, ATTR1A_NAME, H5T_NATIVE_INTEGER, sid2, attr2, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - ! Write attribute information - CALL h5awrite_f(attr2, H5T_NATIVE_INTEGER, attr_data1a, dimsa, error) - CALL check("h5awrite_f",error,total_error) - - ! Check storage size for attribute - - CALL h5aget_storage_size_f(attr, attr_size, error) - CALL check("h5aget_storage_size_f",error,total_error) -!EP CALL verify("h5aget_storage_size_f", INT(attr_size), 2*HSIZE_T, total_error) - - - ! Read attribute information immediately, without closing attribute - CALL h5aread_f(attr, H5T_NATIVE_INTEGER, read_data1, dimsa, error) - CALL check("h5aread_f",error,total_error) - - ! Verify values read in - DO i = 1, ATTR1_DIM1 - CALL verify('h5aread_f',attr_data1(i),read_data1(i), total_error) - ENDDO - - ! CLOSE attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - ! Close attribute - CALL h5aclose_f(attr2, error) - CALL check("h5aclose_f",error,total_error) - - ! change attribute name - CALL H5Arename_f(dataset, ATTR1_NAME, ATTR_TMP_NAME, error) - CALL check("H5Arename_f", error, total_error) - - ! Open attribute again - - CALL h5aopen_f(dataset, ATTR_TMP_NAME, attr, error) - CALL check("h5aopen_f",error,total_error) - - ! Verify new attribute name - ! Set a deliberately small size - - check_name = ' ' ! need to initialize or does not pass test - - size = 1 - CALL H5Aget_name_f(attr, size, check_name, error) - CALL check('H5Aget_name',error,total_error) - - ! Now enter with the corrected size - IF(error.NE.size)THEN - size = error - CALL H5Aget_name_f(attr, size, check_name, error) - CALL check('H5Aget_name',error,total_error) - ENDIF - - IF(TRIM(ADJUSTL(check_name)).NE.TRIM(ADJUSTL(ATTR_TMP_NAME))) THEN - PRINT*,'.'//TRIM(check_name)//'.',LEN_TRIM(check_name) - PRINT*,'.'//TRIM(ATTR_TMP_NAME)//'.',LEN_TRIM(ATTR_TMP_NAME) - WRITE(*,*) 'ERROR: attribute name different: attr_name ='//TRIM(check_name)//'.' - WRITE(*,*) ' should be ='//TRIM(ATTR_TMP_NAME)//'.' - total_error = total_error + 1 - stop - ENDIF - - ! Try with a string buffer that is exactly the correct size - size = 18 - CALL H5Aget_name_f(attr, size, chr_exact_size, error) - CALL check('H5Aget_name_f',error,total_error) - CALL verify('H5Aget_name_f',chr_exact_size,ATTR_TMP_NAME, total_error) - - ! Close attribute - CALL h5aclose_f(attr, error) - CALL check("h5aclose_f",error,total_error) - - CALL h5sclose_f(sid1, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(sid2, error) - CALL check("h5sclose_f",error,total_error) - ! Close Dataset - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid1, error) - CALL check("h5fclose_f",error,total_error) - -END SUBROUTINE test_attr_basic_write - -!*************************************************************** -!** -!** test_attr_many(): Test basic H5A (attribute) code. -!** Tests storing lots of attributes -!** -!*************************************************************** - -SUBROUTINE test_attr_many(new_format, fcpl, fapl, total_error) - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: new_format - INTEGER(HID_T), INTENT(IN) :: fcpl - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - CHARACTER(LEN=8) :: FileName = "tattr.h5" - INTEGER(HID_T) :: fid - INTEGER(HID_T) :: sid - INTEGER(HID_T) :: gid - INTEGER(HID_T) :: aid - INTEGER :: error - - INTEGER(HSIZE_T), DIMENSION(7) :: data_dims - CHARACTER(LEN=5) :: chr5 - - - CHARACTER(LEN=11) :: attrname - CHARACTER(LEN=8), PARAMETER :: GROUP1_NAME="/Group1" - - INTEGER :: u - INTEGER :: nattr - LOGICAL :: exists - INTEGER, DIMENSION(1) :: attr_data1 - - data_dims = 0 - - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Create dataspace for attribute - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create group for attributes - - CALL H5Gcreate_f(fid, GROUP1_NAME, gid, error) - CALL check("H5Gcreate_f", error, total_error) - - ! Create many attributes - - IF(new_format)THEN - nattr = 250 - ELSE - nattr = 2 - ENDIF - - DO u = 0, nattr - 1 - - WRITE(chr5,'(I5.5)') u - attrname = 'attr '//chr5 - CALL H5Aexists_f( gid, attrname, exists, error) - CALL verify("H5Aexists",exists,.FALSE.,total_error ) - - CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error, lapl_id = H5P_DEFAULT_F) - CALL verify("H5Aexists_by_name_f",exists,.FALSE.,total_error ) - - CALL h5acreate_f(gid, attrname, H5T_NATIVE_INTEGER, sid, aid, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5acreate_f",error,total_error) - - CALL H5Aexists_f(gid, attrname, exists, error) - CALL verify("H5Aexists",exists,.TRUE.,total_error ) - - CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) - CALL verify("H5Aexists_by_name_f",exists,.TRUE.,total_error ) - - attr_data1(1) = u - data_dims(1) = 1 - - CALL h5awrite_f(aid, H5T_NATIVE_INTEGER, attr_data1, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - CALL h5aclose_f(aid, error) - CALL check("h5aclose_f",error,total_error) - - CALL H5Aexists_f(gid, attrname, exists, error) - CALL verify("H5Aexists",exists,.TRUE.,total_error ) - - CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) - CALL verify("H5Aexists_by_name_f",exists,.TRUE.,total_error ) - - ENDDO - - ! Close group - CALL H5Gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - - ! Close file - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Close dataspaces - CALL h5sclose_f(sid, error) - CALL check("h5sclose_f",error,total_error) - -END SUBROUTINE test_attr_many - -!------------------------------------------------------------------------- -! * Function: attr_open_check -! * -! * Purpose: Check opening attribute on an object -! * -! * Return: Success: 0 -! * Failure: -1 -! * -! * Programmer: Fortran version (M.S. Breitenfeld) -! * March 21, 2008 -! * -! *------------------------------------------------------------------------- -! - -SUBROUTINE attr_open_check(fid, dsetname, obj_id, max_attrs, total_error ) - - IMPLICIT NONE - INTEGER(HID_T), INTENT(IN) :: fid - CHARACTER(LEN=*), INTENT(IN) :: dsetname - INTEGER(HID_T), INTENT(IN) :: obj_id - INTEGER, INTENT(IN) :: max_attrs - INTEGER, INTENT(INOUT) :: total_error - - INTEGER :: u - CHARACTER (LEN=8) :: attrname - INTEGER :: error - LOGICAL :: f_corder_valid ! Indicates whether the the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(HSIZE_T) :: data_size ! indicates the size, in the number of characters - - INTEGER(HSIZE_T) :: storage_size ! attributes storage requirements - CHARACTER(LEN=2) :: chr2 - INTEGER(HID_T) attr_id - ! Open each attribute on object by index and check that it's the correct one - - DO u = 0, max_attrs-1 - ! Open the attribute - - WRITE(chr2,'(I2.2)') u - attrname = 'attr '//chr2 - - - CALL h5aopen_f(obj_id, attrname, attr_id, error) - CALL check("h5aopen_f",error,total_error) - - - ! Get the attribute's information - - CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_f",error,total_error) - - ! Check that the object's attributes are correct - CALL verify("h5aget_info_f.corder",corder,u,total_error) - CALL verify("h5aget_info_f.corder_valid",f_corder_valid,.TRUE.,total_error) - CALL verify("h5aget_info_f.cset", cset, H5T_CSET_ASCII_F, total_error) - CALL h5aget_storage_size_f(attr_id, storage_size, error) - CALL check("h5aget_storage_size_f",error,total_error) - - CALL verify("h5aget_info_f.data_size", INT(data_size), INT(storage_size), total_error) - - - ! Close attribute - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - - ! Open the attribute - - CALL H5Aopen_by_name_f(obj_id, ".", attrname, attr_id, error, lapl_id=H5P_DEFAULT_F, aapl_id=H5P_DEFAULT_F) - CALL check("H5Aopen_by_name_f", error, total_error) - - CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_f",error,total_error) - ! Check the attribute's information - CALL verify("h5aget_info_f",corder,u,total_error) - CALL verify("h5aget_info_f",f_corder_valid,.TRUE.,total_error) - CALL verify("h5aget_info_f", cset, H5T_CSET_ASCII_F, total_error) - CALL h5aget_storage_size_f(attr_id, storage_size, error) - CALL check("h5aget_storage_size_f",error,total_error) - CALL verify("h5aget_info_f", INT(data_size), INT(storage_size), total_error) - - ! Close attribute - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - - - ! Open the attribute - CALL H5Aopen_by_name_f(fid, dsetname, attrname, attr_id, error) - CALL check("H5Aopen_by_name_f", error, total_error) - - - ! Get the attribute's information - CALL h5aget_info_f(attr_id, f_corder_valid, corder, cset, data_size, error) - CALL check("h5aget_info_f",error,total_error) - - ! Check the attribute's information - CALL verify("h5aget_info_f",corder,u,total_error) - CALL verify("h5aget_info_f",f_corder_valid,.TRUE.,total_error) - CALL verify("h5aget_info_f", cset, H5T_CSET_ASCII_F, total_error) - CALL h5aget_storage_size_f(attr_id, storage_size, error) - CALL check("h5aget_storage_size_f",error,total_error) - CALL verify("h5aget_info_f", INT(data_size), INT(storage_size), total_error) - - ! Close attribute - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - ENDDO - -END SUBROUTINE attr_open_check -END MODULE TH5A_1_8 diff --git a/fortran/test/tH5D.F90 b/fortran/test/tH5D.F90 new file mode 100644 index 0000000..c9ba952 --- /dev/null +++ b/fortran/test/tH5D.F90 @@ -0,0 +1,630 @@ +!****h* root/fortran/test/tH5D.f90 +! +! NAME +! tH5D.f90 +! +! FUNCTION +! Basic testing of Fortran H5D APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests the H5D APIs functionalities of: +! h5dcreate_f, h5dopen_f, h5dclose_f, h5dget_space_f, h5dget_type_f, +! h5dread_f, and h5dwrite_f, h5dget_space_status_f +! +! +! CONTAINS SUBROUTINES +! datasettest, extenddsettest +! +!***** + +! +MODULE TH5D + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + SUBROUTINE datasettest(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + CHARACTER(LEN=5), PARAMETER :: filename = "dsetf" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name + CHARACTER(LEN=9), PARAMETER :: null_dsetname = "null_dset" ! Dataset name + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: null_dset ! Null dataset identifier + INTEGER(HID_T) :: dspace_id ! Dataspace identifier + INTEGER(HID_T) :: null_dspace ! Null dataspace identifier + INTEGER(HID_T) :: dtype_id ! Datatype identifier + + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions + INTEGER :: rank = 2 ! Dataset rank + + INTEGER, DIMENSION(4,6) :: dset_data, data_out ! Data buffers + INTEGER :: error ! Error flag + + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + INTEGER(HSIZE_T), DIMENSION(1) :: null_data_dim + INTEGER :: null_dset_data = 1 ! null data + INTEGER :: flag ! Space allocation status + + ! + ! Initialize the dset_data array. + ! + DO i = 1, 4 + DO j = 1, 6 + dset_data(i,j) = (i-1)*6 + j; + END DO + END DO + ! + ! 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" + STOP + 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 null dataspace. + ! + CALL h5screate_f(H5S_NULL_F, null_dspace, error) + CALL check("h5screate_simple_f", error, total_error) + ! + ! Create the dataset with default properties. + ! + CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + ! + ! Create the null dataset. + ! + CALL h5dcreate_f(file_id, null_dsetname, H5T_NATIVE_INTEGER, null_dspace, null_dset, error) + CALL check("h5dcreate_f", error, total_error) + ! + ! Write the dataset. + ! + data_dims(1) = 4 + data_dims(2) = 6 + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + ! + ! Write null dataset. Nothing can be written. + ! + null_data_dim(1) = 1 + CALL h5dwrite_f(null_dset, H5T_NATIVE_INTEGER, null_dset_data, null_data_dim, error) + 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) + CALL h5dclose_f(null_dset, 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) + CALL h5sclose_f(null_dspace, error) + CALL check("h5sclose_f", error, total_error) + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + ! + ! Open the existing file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + CALL h5dopen_f(file_id, null_dsetname, null_dset, error) + CALL check("h5dopen_f", error, total_error) + + ! Test whether space has been allocated for a dataset + CALL h5dget_space_status_f(dset_id, flag, error) + CALL check("h5dget_space_status_f",error, total_error) + CALL VERIFY("h5dget_space_status_f", flag, H5D_SPACE_STS_ALLOCATED_F, total_error) + + CALL h5dget_space_status_f(null_dset, flag, error) + CALL check("h5dget_space_status_f",error, total_error) + CALL VERIFY("h5dget_space_status_f", flag, H5D_SPACE_STS_NOT_ALLOCATED_F, total_error) + ! + ! Get the dataset type. + ! + CALL h5dget_type_f(dset_id, dtype_id, error) + CALL check("h5dget_type_f", error, total_error) + ! + ! Get the data space. + ! + CALL h5dget_space_f(dset_id, dspace_id, error) + CALL check("h5dget_space_f", error, total_error) + ! + ! Read the dataset. + ! + CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error) + CALL check("h5dread_f", error, total_error) + ! + ! Read the null dataset. Nothing should be read. + ! + CALL h5dread_f(null_dset, H5T_NATIVE_INTEGER, null_dset_data, null_data_dim, error) + CALL check("h5dread_f", error, total_error) + ! + !Compare the data. + ! + DO i = 1, 4 + DO j = 1, 6 + IF (data_out(i,j) .NE. dset_data(i, j)) THEN + WRITE(*, *) "dataset test error occured" + WRITE(*,*) "data read is not the same as the data written" + END IF + END DO + END DO + ! + ! Check if no change to null_dset_data + ! + IF (null_dset_data .NE. 1) THEN + WRITE(*, *) "null dataset test error occured" + END IF + ! + ! End access to the dataset and release resources used by it. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5dclose_f(null_dset, 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 data type. + ! + CALL h5tclose_f(dtype_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) + IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + RETURN + END SUBROUTINE datasettest + +! +!the following subroutine tests h5dextend_f functionality +! + + SUBROUTINE extenddsettest(cleanup, total_error) + + IMPLICIT NONE + + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + ! + !the dataset is stored in file "extf.h5" + ! + CHARACTER(LEN=4), PARAMETER :: filename = "extf" + CHARACTER(LEN=80) :: fix_filename + + ! + !dataset name is "ExtendibleArray" + ! + CHARACTER(LEN=15), PARAMETER :: dsetname = "ExtendibleArray" + + ! + !dataset rank is 2 + ! + INTEGER :: RANK = 2 + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dataspace ! Dataspace identifier + INTEGER(HID_T) :: memspace ! memory Dataspace identifier + INTEGER(HID_T) :: crp_list ! dataset creatation property identifier + + ! + !dataset dimensions at creation time + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/3,3/) + + ! + !data dimensions + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/10,3/) + + ! + !Maximum dimensions + ! + INTEGER(HSIZE_T), DIMENSION(2) :: maxdims + + ! + !data arrays for reading and writing + ! + INTEGER, DIMENSION(10,3) :: data_in, data_out + + ! + !Size of data in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: size + + ! + !general purpose integer + ! + INTEGER :: i, j + INTEGER(HSIZE_T) :: ih, jh + + ! + !flag to check operation success + ! + INTEGER :: error + + ! + !Variables used in reading data back + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dimsr, maxdimsr + INTEGER :: rankr + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + + ! + !data initialization + ! + DO i = 1, 10 + DO j = 1, 3 + data_in(i,j) = 2 + END DO + END DO + + ! + !Initialize FORTRAN predifined datatypes + ! +! CALL h5init_types_f(error) +! CALL check("h5init_types_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" + STOP + ENDIF + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + ! + !Create the data space with unlimited dimensions. + ! + maxdims = (/H5S_UNLIMITED_F, H5S_UNLIMITED_F/) + + CALL h5screate_simple_f(RANK, dims, dataspace, error, maxdims) + CALL check("h5screate_simple_f",error,total_error) + + ! + !Modify dataset creation properties, i.e. enable chunking + ! + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) + CALL check("h5pcreate_f",error,total_error) + + CALL h5pset_chunk_f(crp_list, RANK, dims1, error) + CALL check("h5pset_chunk_f",error,total_error) + + ! + !Create a dataset with 3X3 dimensions using cparms creation propertie . + ! + CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dataspace, dset_id, error, crp_list ) + CALL check("h5dcreate_f",error,total_error) + + ! + !Extend the dataset. This call assures that dataset is 3 x 3. + ! + SIZE(1) = 3 + SIZE(2) = 3 + CALL h5dextend_f(dset_id, size, error) + CALL check("h5dextend_f",error,total_error) + + + ! + !Extend the dataset. Dataset becomes 10 x 3. + ! + SIZE(1) = 10; + SIZE(2) = 3; + CALL h5dextend_f(dset_id, size, error) + CALL check("h5dextend_f",error,total_error) + + ! + !Write the data of size 10X3 to the extended dataset. + ! + data_dims(1) = 10 + data_dims(2) = 3 + CALL H5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data_in, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f",error,total_error) + + ! + !Close the property list. + ! + CALL h5pclose_f(crp_list, error) + CALL check("h5pclose_f",error,total_error) + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + + ! + !Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + + ! + !read the data back + ! + !Open the file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDONLY_F, file_id, error) + CALL check("hfopen_f",error,total_error) + + ! + !Open the dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f",error,total_error) + + ! + !Get dataset's dataspace handle. + ! + CALL h5dget_space_f(dset_id, dataspace, error) + CALL check("h5dget_space_f",error,total_error) + + ! + !Get dataspace's rank. + ! + CALL h5sget_simple_extent_ndims_f(dataspace, rankr, error) + CALL check("h5sget_simple_extent_ndims_f",error,total_error) + IF (rankr .NE. RANK) THEN + WRITE(*,*) "dataset rank error occured" + STOP + END IF + + ! + !Get dataspace's dimensinons. + ! + CALL h5sget_simple_extent_dims_f(dataspace, dimsr, maxdimsr, error) + CALL check("h5sget_simple_extent_dims_f",error,total_error) + IF ((dimsr(1) .NE. dims1(1)) .OR. (dimsr(2) .NE. dims1(2))) THEN + WRITE(*,*) "dataset dimensions error occured" + STOP + END IF + + ! + !Get creation property list. + ! + CALL h5dget_create_plist_f(dset_id, crp_list, error) + CALL check("h5dget_create_plist_f",error,total_error) + + + ! + !create memory dataspace. + ! + CALL h5screate_simple_f(rankr, dimsr, memspace, error) + CALL check("h5screate_simple_f",error,total_error) + + ! + !Read data + ! + CALL H5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, memspace, dataspace) + CALL check("h5dread_f",error,total_error) + + + ! + !Compare the data. + ! + DO ih = 1, dims1(1) + DO jh = 1, dims1(2) + IF (data_out(ih,jh) .NE. data_in(ih, jh)) THEN + WRITE(*, *) "extend dataset test error occured" + WRITE(*, *) "read value is not the same as the written values" + END IF + END DO + END DO + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f",error,total_error) + + ! + !Close the memspace for the dataset. + ! + CALL h5sclose_f(memspace, error) + CALL check("h5sclose_f",error,total_error) + + ! + !Close the property list. + ! + CALL h5pclose_f(crp_list, error) + CALL check("h5pclose_f",error,total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + + ! + !Close the file. + ! + 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 extenddsettest + +! +! The following subroutine tests h5dget_offset_f functionality +! + + SUBROUTINE test_userblock_offset(cleanup, total_error) + + USE ISO_C_BINDING + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + ! + !the dataset is stored in file "offset.h5" + ! + INTEGER, PARAMETER :: dset_dim1=2, dset_dim2=10 + CHARACTER(LEN=6), PARAMETER :: filename = "offset" + CHARACTER(LEN=80) :: fix_filename + + INTEGER(hid_t) :: file, fcpl, dataset, space + INTEGER :: i, j, n, ios + INTEGER(hsize_t), DIMENSION(1:2) :: dims + INTEGER :: f + INTEGER(haddr_t) :: offset + INTEGER, DIMENSION(1:dset_dim1,1:dset_dim2), TARGET :: rdata, data_in + INTEGER :: error + TYPE(C_PTR) :: f_ptr + ! + !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" + STOP + ENDIF + + CALL h5pcreate_f(H5P_FILE_CREATE_F, fcpl, error) + CALL check("h5pcreate_f",error,total_error) + + ! Initialize the dataset + n = 0 + DO i = 1, dset_dim1 + DO j = 1, dset_dim2 + n = n + 1 + data_in(i,j) = n + END DO + END DO + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file, error, fcpl) + CALL check("h5fcreate_f",error,total_error) + + ! Create the data space + dims(1:2) = (/dset_dim1,dset_dim2/) + + CALL h5screate_simple_f(2, dims, space, error) + CALL check("h5screate_simple_f",error,total_error) + + ! Create the dataset + CALL h5dcreate_f(file, "dset1", H5T_NATIVE_INTEGER, space, dataset, error) + CALL check("h5dcreate_f", error, total_error) + + ! Test dataset address. Should be undefined. + CALL h5dget_offset_f(dataset, offset, error) + CALL VERIFY("h5dget_offset_f",offset, HADDR_UNDEF_F, total_error) + + ! Write the data to the dataset + f_ptr = C_LOC(data_in(1,1)) + CALL h5dwrite_f(dataset, H5T_NATIVE_INTEGER, f_ptr, error) + CALL check("h5dwrite_f", error, total_error) + + ! Test dataset address in file. Open the same file as a C file, seek + ! the data position as H5Dget_offset points to, read the dataset, and + ! compare it with the data written in. + CALL h5dget_offset_f(dataset, offset, error) + CALL check("h5dget_offset_f", error, total_error) + IF(offset.EQ.HADDR_UNDEF_F)THEN + total_error = total_error + 1 + ENDIF + + CALL h5dclose_f(dataset, error) + CALL check("h5dclose_f", error, total_error) + CALL h5fclose_f(file, error) + CALL check("h5fclose_f", error, total_error) + + IF(total_error.NE.0) RETURN + + OPEN(10,FILE=fix_filename, ACCESS="STREAM", IOSTAT=ios) + IF(ios.NE.0)THEN + WRITE(*,'(A)') "Failed to open file "//TRIM(fix_filename) + total_error = total_error + 1 + RETURN + ENDIF + ! The pos= specifier illustrates that positions are in bytes, + ! starting from byte 1 (as opposed to C, where they start from byte 0) + READ(10, POS=offset+1, IOSTAT=ios) rdata + IF(ios.NE.0)THEN + WRITE(*,'(A)') "Failed to read data from stream I/O " + total_error = total_error + 1 + CLOSE(10) + RETURN + ENDIF + + ! Check that the values read are the same as the values written + DO i = 1, dset_dim1 + DO j = 1, dset_dim2 + CALL VERIFY("h5dget_offset_f",rdata(i,j), data_in(i,j), total_error) + IF(total_error.NE.0)THEN + WRITE(*,'(A)') " Read different values than written." + WRITE(*,'(2(A,I0))') " At index ",i,",",j + CLOSE(10) + RETURN + ENDIF + END DO + END DO + + CLOSE(10) + + END SUBROUTINE test_userblock_offset + +END MODULE TH5D + diff --git a/fortran/test/tH5D.f90 b/fortran/test/tH5D.f90 deleted file mode 100644 index c9ba952..0000000 --- a/fortran/test/tH5D.f90 +++ /dev/null @@ -1,630 +0,0 @@ -!****h* root/fortran/test/tH5D.f90 -! -! NAME -! tH5D.f90 -! -! FUNCTION -! Basic testing of Fortran H5D APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! NOTES -! Tests the H5D APIs functionalities of: -! h5dcreate_f, h5dopen_f, h5dclose_f, h5dget_space_f, h5dget_type_f, -! h5dread_f, and h5dwrite_f, h5dget_space_status_f -! -! -! CONTAINS SUBROUTINES -! datasettest, extenddsettest -! -!***** - -! -MODULE TH5D - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - SUBROUTINE datasettest(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - CHARACTER(LEN=5), PARAMETER :: filename = "dsetf" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name - CHARACTER(LEN=9), PARAMETER :: null_dsetname = "null_dset" ! Dataset name - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: null_dset ! Null dataset identifier - INTEGER(HID_T) :: dspace_id ! Dataspace identifier - INTEGER(HID_T) :: null_dspace ! Null dataspace identifier - INTEGER(HID_T) :: dtype_id ! Datatype identifier - - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions - INTEGER :: rank = 2 ! Dataset rank - - INTEGER, DIMENSION(4,6) :: dset_data, data_out ! Data buffers - INTEGER :: error ! Error flag - - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - INTEGER(HSIZE_T), DIMENSION(1) :: null_data_dim - INTEGER :: null_dset_data = 1 ! null data - INTEGER :: flag ! Space allocation status - - ! - ! Initialize the dset_data array. - ! - DO i = 1, 4 - DO j = 1, 6 - dset_data(i,j) = (i-1)*6 + j; - END DO - END DO - ! - ! 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" - STOP - 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 null dataspace. - ! - CALL h5screate_f(H5S_NULL_F, null_dspace, error) - CALL check("h5screate_simple_f", error, total_error) - ! - ! Create the dataset with default properties. - ! - CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f", error, total_error) - ! - ! Create the null dataset. - ! - CALL h5dcreate_f(file_id, null_dsetname, H5T_NATIVE_INTEGER, null_dspace, null_dset, error) - CALL check("h5dcreate_f", error, total_error) - ! - ! Write the dataset. - ! - data_dims(1) = 4 - data_dims(2) = 6 - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) - CALL check("h5dwrite_f", error, total_error) - ! - ! Write null dataset. Nothing can be written. - ! - null_data_dim(1) = 1 - CALL h5dwrite_f(null_dset, H5T_NATIVE_INTEGER, null_dset_data, null_data_dim, error) - 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) - CALL h5dclose_f(null_dset, 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) - CALL h5sclose_f(null_dspace, error) - CALL check("h5sclose_f", error, total_error) - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - ! - ! Open the existing file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - CALL h5dopen_f(file_id, null_dsetname, null_dset, error) - CALL check("h5dopen_f", error, total_error) - - ! Test whether space has been allocated for a dataset - CALL h5dget_space_status_f(dset_id, flag, error) - CALL check("h5dget_space_status_f",error, total_error) - CALL VERIFY("h5dget_space_status_f", flag, H5D_SPACE_STS_ALLOCATED_F, total_error) - - CALL h5dget_space_status_f(null_dset, flag, error) - CALL check("h5dget_space_status_f",error, total_error) - CALL VERIFY("h5dget_space_status_f", flag, H5D_SPACE_STS_NOT_ALLOCATED_F, total_error) - ! - ! Get the dataset type. - ! - CALL h5dget_type_f(dset_id, dtype_id, error) - CALL check("h5dget_type_f", error, total_error) - ! - ! Get the data space. - ! - CALL h5dget_space_f(dset_id, dspace_id, error) - CALL check("h5dget_space_f", error, total_error) - ! - ! Read the dataset. - ! - CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error) - CALL check("h5dread_f", error, total_error) - ! - ! Read the null dataset. Nothing should be read. - ! - CALL h5dread_f(null_dset, H5T_NATIVE_INTEGER, null_dset_data, null_data_dim, error) - CALL check("h5dread_f", error, total_error) - ! - !Compare the data. - ! - DO i = 1, 4 - DO j = 1, 6 - IF (data_out(i,j) .NE. dset_data(i, j)) THEN - WRITE(*, *) "dataset test error occured" - WRITE(*,*) "data read is not the same as the data written" - END IF - END DO - END DO - ! - ! Check if no change to null_dset_data - ! - IF (null_dset_data .NE. 1) THEN - WRITE(*, *) "null dataset test error occured" - END IF - ! - ! End access to the dataset and release resources used by it. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5dclose_f(null_dset, 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 data type. - ! - CALL h5tclose_f(dtype_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) - IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - RETURN - END SUBROUTINE datasettest - -! -!the following subroutine tests h5dextend_f functionality -! - - SUBROUTINE extenddsettest(cleanup, total_error) - - IMPLICIT NONE - - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - ! - !the dataset is stored in file "extf.h5" - ! - CHARACTER(LEN=4), PARAMETER :: filename = "extf" - CHARACTER(LEN=80) :: fix_filename - - ! - !dataset name is "ExtendibleArray" - ! - CHARACTER(LEN=15), PARAMETER :: dsetname = "ExtendibleArray" - - ! - !dataset rank is 2 - ! - INTEGER :: RANK = 2 - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dataspace ! Dataspace identifier - INTEGER(HID_T) :: memspace ! memory Dataspace identifier - INTEGER(HID_T) :: crp_list ! dataset creatation property identifier - - ! - !dataset dimensions at creation time - ! - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/3,3/) - - ! - !data dimensions - ! - INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/10,3/) - - ! - !Maximum dimensions - ! - INTEGER(HSIZE_T), DIMENSION(2) :: maxdims - - ! - !data arrays for reading and writing - ! - INTEGER, DIMENSION(10,3) :: data_in, data_out - - ! - !Size of data in the file - ! - INTEGER(HSIZE_T), DIMENSION(2) :: size - - ! - !general purpose integer - ! - INTEGER :: i, j - INTEGER(HSIZE_T) :: ih, jh - - ! - !flag to check operation success - ! - INTEGER :: error - - ! - !Variables used in reading data back - ! - INTEGER(HSIZE_T), DIMENSION(2) :: dimsr, maxdimsr - INTEGER :: rankr - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - - ! - !data initialization - ! - DO i = 1, 10 - DO j = 1, 3 - data_in(i,j) = 2 - END DO - END DO - - ! - !Initialize FORTRAN predifined datatypes - ! -! CALL h5init_types_f(error) -! CALL check("h5init_types_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" - STOP - ENDIF - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - ! - !Create the data space with unlimited dimensions. - ! - maxdims = (/H5S_UNLIMITED_F, H5S_UNLIMITED_F/) - - CALL h5screate_simple_f(RANK, dims, dataspace, error, maxdims) - CALL check("h5screate_simple_f",error,total_error) - - ! - !Modify dataset creation properties, i.e. enable chunking - ! - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) - CALL check("h5pcreate_f",error,total_error) - - CALL h5pset_chunk_f(crp_list, RANK, dims1, error) - CALL check("h5pset_chunk_f",error,total_error) - - ! - !Create a dataset with 3X3 dimensions using cparms creation propertie . - ! - CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dataspace, dset_id, error, crp_list ) - CALL check("h5dcreate_f",error,total_error) - - ! - !Extend the dataset. This call assures that dataset is 3 x 3. - ! - SIZE(1) = 3 - SIZE(2) = 3 - CALL h5dextend_f(dset_id, size, error) - CALL check("h5dextend_f",error,total_error) - - - ! - !Extend the dataset. Dataset becomes 10 x 3. - ! - SIZE(1) = 10; - SIZE(2) = 3; - CALL h5dextend_f(dset_id, size, error) - CALL check("h5dextend_f",error,total_error) - - ! - !Write the data of size 10X3 to the extended dataset. - ! - data_dims(1) = 10 - data_dims(2) = 3 - CALL H5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data_in, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - - ! - !Close the dataspace for the dataset. - ! - CALL h5sclose_f(dataspace, error) - CALL check("h5sclose_f",error,total_error) - - ! - !Close the property list. - ! - CALL h5pclose_f(crp_list, error) - CALL check("h5pclose_f",error,total_error) - ! - !Close the dataset. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - - ! - !Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - - ! - !read the data back - ! - !Open the file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDONLY_F, file_id, error) - CALL check("hfopen_f",error,total_error) - - ! - !Open the dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f",error,total_error) - - ! - !Get dataset's dataspace handle. - ! - CALL h5dget_space_f(dset_id, dataspace, error) - CALL check("h5dget_space_f",error,total_error) - - ! - !Get dataspace's rank. - ! - CALL h5sget_simple_extent_ndims_f(dataspace, rankr, error) - CALL check("h5sget_simple_extent_ndims_f",error,total_error) - IF (rankr .NE. RANK) THEN - WRITE(*,*) "dataset rank error occured" - STOP - END IF - - ! - !Get dataspace's dimensinons. - ! - CALL h5sget_simple_extent_dims_f(dataspace, dimsr, maxdimsr, error) - CALL check("h5sget_simple_extent_dims_f",error,total_error) - IF ((dimsr(1) .NE. dims1(1)) .OR. (dimsr(2) .NE. dims1(2))) THEN - WRITE(*,*) "dataset dimensions error occured" - STOP - END IF - - ! - !Get creation property list. - ! - CALL h5dget_create_plist_f(dset_id, crp_list, error) - CALL check("h5dget_create_plist_f",error,total_error) - - - ! - !create memory dataspace. - ! - CALL h5screate_simple_f(rankr, dimsr, memspace, error) - CALL check("h5screate_simple_f",error,total_error) - - ! - !Read data - ! - CALL H5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, memspace, dataspace) - CALL check("h5dread_f",error,total_error) - - - ! - !Compare the data. - ! - DO ih = 1, dims1(1) - DO jh = 1, dims1(2) - IF (data_out(ih,jh) .NE. data_in(ih, jh)) THEN - WRITE(*, *) "extend dataset test error occured" - WRITE(*, *) "read value is not the same as the written values" - END IF - END DO - END DO - - ! - !Close the dataspace for the dataset. - ! - CALL h5sclose_f(dataspace, error) - CALL check("h5sclose_f",error,total_error) - - ! - !Close the memspace for the dataset. - ! - CALL h5sclose_f(memspace, error) - CALL check("h5sclose_f",error,total_error) - - ! - !Close the property list. - ! - CALL h5pclose_f(crp_list, error) - CALL check("h5pclose_f",error,total_error) - - ! - !Close the dataset. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - - ! - !Close the file. - ! - 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 extenddsettest - -! -! The following subroutine tests h5dget_offset_f functionality -! - - SUBROUTINE test_userblock_offset(cleanup, total_error) - - USE ISO_C_BINDING - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - ! - !the dataset is stored in file "offset.h5" - ! - INTEGER, PARAMETER :: dset_dim1=2, dset_dim2=10 - CHARACTER(LEN=6), PARAMETER :: filename = "offset" - CHARACTER(LEN=80) :: fix_filename - - INTEGER(hid_t) :: file, fcpl, dataset, space - INTEGER :: i, j, n, ios - INTEGER(hsize_t), DIMENSION(1:2) :: dims - INTEGER :: f - INTEGER(haddr_t) :: offset - INTEGER, DIMENSION(1:dset_dim1,1:dset_dim2), TARGET :: rdata, data_in - INTEGER :: error - TYPE(C_PTR) :: f_ptr - ! - !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" - STOP - ENDIF - - CALL h5pcreate_f(H5P_FILE_CREATE_F, fcpl, error) - CALL check("h5pcreate_f",error,total_error) - - ! Initialize the dataset - n = 0 - DO i = 1, dset_dim1 - DO j = 1, dset_dim2 - n = n + 1 - data_in(i,j) = n - END DO - END DO - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file, error, fcpl) - CALL check("h5fcreate_f",error,total_error) - - ! Create the data space - dims(1:2) = (/dset_dim1,dset_dim2/) - - CALL h5screate_simple_f(2, dims, space, error) - CALL check("h5screate_simple_f",error,total_error) - - ! Create the dataset - CALL h5dcreate_f(file, "dset1", H5T_NATIVE_INTEGER, space, dataset, error) - CALL check("h5dcreate_f", error, total_error) - - ! Test dataset address. Should be undefined. - CALL h5dget_offset_f(dataset, offset, error) - CALL VERIFY("h5dget_offset_f",offset, HADDR_UNDEF_F, total_error) - - ! Write the data to the dataset - f_ptr = C_LOC(data_in(1,1)) - CALL h5dwrite_f(dataset, H5T_NATIVE_INTEGER, f_ptr, error) - CALL check("h5dwrite_f", error, total_error) - - ! Test dataset address in file. Open the same file as a C file, seek - ! the data position as H5Dget_offset points to, read the dataset, and - ! compare it with the data written in. - CALL h5dget_offset_f(dataset, offset, error) - CALL check("h5dget_offset_f", error, total_error) - IF(offset.EQ.HADDR_UNDEF_F)THEN - total_error = total_error + 1 - ENDIF - - CALL h5dclose_f(dataset, error) - CALL check("h5dclose_f", error, total_error) - CALL h5fclose_f(file, error) - CALL check("h5fclose_f", error, total_error) - - IF(total_error.NE.0) RETURN - - OPEN(10,FILE=fix_filename, ACCESS="STREAM", IOSTAT=ios) - IF(ios.NE.0)THEN - WRITE(*,'(A)') "Failed to open file "//TRIM(fix_filename) - total_error = total_error + 1 - RETURN - ENDIF - ! The pos= specifier illustrates that positions are in bytes, - ! starting from byte 1 (as opposed to C, where they start from byte 0) - READ(10, POS=offset+1, IOSTAT=ios) rdata - IF(ios.NE.0)THEN - WRITE(*,'(A)') "Failed to read data from stream I/O " - total_error = total_error + 1 - CLOSE(10) - RETURN - ENDIF - - ! Check that the values read are the same as the values written - DO i = 1, dset_dim1 - DO j = 1, dset_dim2 - CALL VERIFY("h5dget_offset_f",rdata(i,j), data_in(i,j), total_error) - IF(total_error.NE.0)THEN - WRITE(*,'(A)') " Read different values than written." - WRITE(*,'(2(A,I0))') " At index ",i,",",j - CLOSE(10) - RETURN - ENDIF - END DO - END DO - - CLOSE(10) - - END SUBROUTINE test_userblock_offset - -END MODULE TH5D - diff --git a/fortran/test/tH5E.F90 b/fortran/test/tH5E.F90 new file mode 100644 index 0000000..10ecaf6 --- /dev/null +++ b/fortran/test/tH5E.F90 @@ -0,0 +1,102 @@ +!****h* root/fortran/test/tH5E.f90 +! +! NAME +! tH5E.f90 +! +! FUNCTION +! Basic testing of Fortran H5E APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests the H5D APIs functionalities of: +! h5eprint_f +! +! CONTAINS SUBROUTINES +! error_report_test +! +!***** +! +MODULE TH5E + +CONTAINS + + SUBROUTINE error_report_test(cleanup, total_error) + +! This subroutine tests following functionalities: h5eprint_f + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=6), PARAMETER :: filename = "etestf" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=8), PARAMETER :: err_filename = "err_file"! Error output file + CHARACTER(LEN=80) :: fix_err_filename + + + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: grp_id ! Group identifier + INTEGER :: error, tmp_error, err_flag + + err_flag = 0 + CALL h5eset_auto_f(err_flag, error) + CALL check("h5eprint_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" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + ! + ! Try to open non-existing group in the file. + ! Error message should go to the err_file_name file. + ! + CALL h5gopen_f(file_id, "Doesnotexist1", grp_id, tmp_error) + CALL h5_fixname_f(err_filename, fix_err_filename, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5eprint_f(error, fix_err_filename) + CALL h5gopen_f(file_id, "Doesnotexist2", grp_id, tmp_error) + CALL h5eprint_f(error, fix_err_filename) + + ! + ! Close the file. + ! + 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) + if(cleanup) CALL h5_cleanup_f(err_filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + RETURN + END SUBROUTINE error_report_test + +END MODULE TH5E + diff --git a/fortran/test/tH5E.f90 b/fortran/test/tH5E.f90 deleted file mode 100644 index 10ecaf6..0000000 --- a/fortran/test/tH5E.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!****h* root/fortran/test/tH5E.f90 -! -! NAME -! tH5E.f90 -! -! FUNCTION -! Basic testing of Fortran H5E APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! NOTES -! Tests the H5D APIs functionalities of: -! h5eprint_f -! -! CONTAINS SUBROUTINES -! error_report_test -! -!***** -! -MODULE TH5E - -CONTAINS - - SUBROUTINE error_report_test(cleanup, total_error) - -! This subroutine tests following functionalities: h5eprint_f - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=6), PARAMETER :: filename = "etestf" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=8), PARAMETER :: err_filename = "err_file"! Error output file - CHARACTER(LEN=80) :: fix_err_filename - - - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: grp_id ! Group identifier - INTEGER :: error, tmp_error, err_flag - - err_flag = 0 - CALL h5eset_auto_f(err_flag, error) - CALL check("h5eprint_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" - stop - endif - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - ! - ! Try to open non-existing group in the file. - ! Error message should go to the err_file_name file. - ! - CALL h5gopen_f(file_id, "Doesnotexist1", grp_id, tmp_error) - CALL h5_fixname_f(err_filename, fix_err_filename, H5P_DEFAULT_F, error) - if (error .ne. 0) then - write(*,*) "Cannot modify filename" - stop - endif - CALL h5eprint_f(error, fix_err_filename) - CALL h5gopen_f(file_id, "Doesnotexist2", grp_id, tmp_error) - CALL h5eprint_f(error, fix_err_filename) - - ! - ! Close the file. - ! - 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) - if(cleanup) CALL h5_cleanup_f(err_filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - RETURN - END SUBROUTINE error_report_test - -END MODULE TH5E - diff --git a/fortran/test/tH5E_F03.F90 b/fortran/test/tH5E_F03.F90 new file mode 100644 index 0000000..63e70a3 --- /dev/null +++ b/fortran/test/tH5E_F03.F90 @@ -0,0 +1,203 @@ +!****h* root/fortran/test/tH5E_F03.f90 +! +! NAME +! tH5E_F03.f90 +! +! FUNCTION +! Test FORTRAN HDF5 H5E 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. 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_error +! +!***** + +! ***************************************** +! *** H 5 E T E S T S +! ***************************************** +MODULE test_my_hdf5_error_handler + + USE HDF5 + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +!*************************************************************** +!** +!** my_hdf5_error_handler: Custom error callback routine. +!** +!*************************************************************** + + INTEGER FUNCTION my_hdf5_error_handler(estack_id, data_inout) bind(C) + + ! This error function handle works with only version 2 error stack + + IMPLICIT NONE + + ! estack_id is always passed from C as: H5E_DEFAULT + INTEGER(HID_T) :: estack_id + ! data that was registered with H5Eset_auto_f + INTEGER :: data_inout + + PRINT*, " " + PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, WITH DATA" + PRINT*, " -This message should be written to standard out- " + PRINT*, " Data Values Passed In =", data_inout + PRINT*, " " + + data_inout = 10*data_inout + + my_hdf5_error_handler = 1 ! this is not used by the C routine + + END FUNCTION my_hdf5_error_handler + + INTEGER FUNCTION my_hdf5_error_handler_nodata(estack_id, data_inout) bind(C) + + ! This error function handle works with only version 2 error stack + + IMPLICIT NONE + + ! estack_id is always passed from C as: H5E_DEFAULT + INTEGER(HID_T) :: estack_id + ! data that was registered with H5Eset_auto_f + TYPE(C_PTR) :: data_inout + + PRINT*, " " + PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, NO DATA" + PRINT*, " -This message should be written to standard out- " + PRINT*, " " + + my_hdf5_error_handler_nodata = 1 ! this is not used by the C routine + + END FUNCTION my_hdf5_error_handler_nodata + +END MODULE test_my_hdf5_error_handler + + + +MODULE TH5E_F03 + +CONTAINS + +SUBROUTINE test_error(total_error) + + USE ISO_C_BINDING + USE test_my_hdf5_error_handler + + IMPLICIT NONE + + INTEGER(hid_t), PARAMETER :: FAKE_ID = -1 + INTEGER :: total_error + INTEGER(hid_t) :: file + INTEGER(hid_t) :: dataset, space + INTEGER(hsize_t), DIMENSION(1:2) :: dims + INTEGER :: error + INTEGER, DIMENSION(:), POINTER :: ptr_data + INTEGER, TARGET :: my_hdf5_error_handler_data + TYPE(C_PTR) :: f_ptr + TYPE(C_FUNPTR) :: func + + TYPE(C_PTR), TARGET :: f_ptr1 + + INTEGER, DIMENSION(1:1) :: array_shape + + my_hdf5_error_handler_data = 99 + CALL h5fcreate_f("terror.h5", H5F_ACC_TRUNC_F, file, error) + CALL check("h5fcreate_f", error, total_error) + + ! Create the data space + dims(1) = 10 + dims(2) = 20 + CALL H5Screate_simple_f(2, dims, space, error) + CALL check("h5screate_simple_f", error, total_error) + + ! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK ** + + ! set the customized error handling routine + func = c_funloc(my_hdf5_error_handler) + + ! set the data sent to the customized routine + f_ptr = c_loc(my_hdf5_error_handler_data) + + ! turn on automatic printing, and use a custom error routine with input data + CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) + + ! Create the erring dataset + CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + CALL verify("h5dcreate_f", error, -1, total_error) + +!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(1),10, total_error) +!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(2),20, total_error) + +!!$ ! Test enabling and disabling default printing +!!$ +!!$ CALL H5Eget_auto_f(H5E_DEFAULT_F, func1, f_ptr1, error) +!!$ CALL verify("H5Eget_auto_f", error, 0, total_error) + + ! PRINT*,c_associated(f_ptr1) + + ALLOCATE(ptr_data(1:2)) + ptr_data = 0 + array_shape(1) = 2 + CALL C_F_POINTER(f_ptr1, ptr_data, array_shape) + + ! ptr_data => f_ptr1(1) + + ! PRINT*,ptr_data(1) + +!!$ if(old_data != NULL) +!!$ TEST_ERROR; +!!$#ifdef H5_USE_16_API +!!$ if (old_func != (H5E_auto_t)H5Eprint) +!!$ TEST_ERROR; +!!$#else H5_USE_16_API +!!$ if (old_func != (H5E_auto2_t)H5Eprint2) +!!$ TEST_ERROR; +!!$#endif H5_USE_16_API + + + ! set the customized error handling routine + func = c_funloc(my_hdf5_error_handler_nodata) + ! set the data sent to the customized routine as null + f_ptr = C_NULL_PTR + ! turn on automatic printing, and use a custom error routine with no input data + CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) + + CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + CALL verify("h5dcreate_f", error, -1, total_error) + + + ! turn on automatic printing with h5eprint_f which prints an error stack in the default manner. + + ! func = c_funloc(h5eprint_f) + ! CALL H5Eset_auto_f(0, error, H5E_DEFAULT_F, func, C_NULL_PTR) + + CALL H5Eset_auto_f(0, error) + CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + + CALL H5Eset_auto_f(1, error) + CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) + +END SUBROUTINE test_error + +END MODULE TH5E_F03 diff --git a/fortran/test/tH5E_F03.f90 b/fortran/test/tH5E_F03.f90 deleted file mode 100644 index 63e70a3..0000000 --- a/fortran/test/tH5E_F03.f90 +++ /dev/null @@ -1,203 +0,0 @@ -!****h* root/fortran/test/tH5E_F03.f90 -! -! NAME -! tH5E_F03.f90 -! -! FUNCTION -! Test FORTRAN HDF5 H5E 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. 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_error -! -!***** - -! ***************************************** -! *** H 5 E T E S T S -! ***************************************** -MODULE test_my_hdf5_error_handler - - USE HDF5 - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -!*************************************************************** -!** -!** my_hdf5_error_handler: Custom error callback routine. -!** -!*************************************************************** - - INTEGER FUNCTION my_hdf5_error_handler(estack_id, data_inout) bind(C) - - ! This error function handle works with only version 2 error stack - - IMPLICIT NONE - - ! estack_id is always passed from C as: H5E_DEFAULT - INTEGER(HID_T) :: estack_id - ! data that was registered with H5Eset_auto_f - INTEGER :: data_inout - - PRINT*, " " - PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, WITH DATA" - PRINT*, " -This message should be written to standard out- " - PRINT*, " Data Values Passed In =", data_inout - PRINT*, " " - - data_inout = 10*data_inout - - my_hdf5_error_handler = 1 ! this is not used by the C routine - - END FUNCTION my_hdf5_error_handler - - INTEGER FUNCTION my_hdf5_error_handler_nodata(estack_id, data_inout) bind(C) - - ! This error function handle works with only version 2 error stack - - IMPLICIT NONE - - ! estack_id is always passed from C as: H5E_DEFAULT - INTEGER(HID_T) :: estack_id - ! data that was registered with H5Eset_auto_f - TYPE(C_PTR) :: data_inout - - PRINT*, " " - PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, NO DATA" - PRINT*, " -This message should be written to standard out- " - PRINT*, " " - - my_hdf5_error_handler_nodata = 1 ! this is not used by the C routine - - END FUNCTION my_hdf5_error_handler_nodata - -END MODULE test_my_hdf5_error_handler - - - -MODULE TH5E_F03 - -CONTAINS - -SUBROUTINE test_error(total_error) - - USE ISO_C_BINDING - USE test_my_hdf5_error_handler - - IMPLICIT NONE - - INTEGER(hid_t), PARAMETER :: FAKE_ID = -1 - INTEGER :: total_error - INTEGER(hid_t) :: file - INTEGER(hid_t) :: dataset, space - INTEGER(hsize_t), DIMENSION(1:2) :: dims - INTEGER :: error - INTEGER, DIMENSION(:), POINTER :: ptr_data - INTEGER, TARGET :: my_hdf5_error_handler_data - TYPE(C_PTR) :: f_ptr - TYPE(C_FUNPTR) :: func - - TYPE(C_PTR), TARGET :: f_ptr1 - - INTEGER, DIMENSION(1:1) :: array_shape - - my_hdf5_error_handler_data = 99 - CALL h5fcreate_f("terror.h5", H5F_ACC_TRUNC_F, file, error) - CALL check("h5fcreate_f", error, total_error) - - ! Create the data space - dims(1) = 10 - dims(2) = 20 - CALL H5Screate_simple_f(2, dims, space, error) - CALL check("h5screate_simple_f", error, total_error) - - ! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK ** - - ! set the customized error handling routine - func = c_funloc(my_hdf5_error_handler) - - ! set the data sent to the customized routine - f_ptr = c_loc(my_hdf5_error_handler_data) - - ! turn on automatic printing, and use a custom error routine with input data - CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) - - ! Create the erring dataset - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - CALL verify("h5dcreate_f", error, -1, total_error) - -!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(1),10, total_error) -!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(2),20, total_error) - -!!$ ! Test enabling and disabling default printing -!!$ -!!$ CALL H5Eget_auto_f(H5E_DEFAULT_F, func1, f_ptr1, error) -!!$ CALL verify("H5Eget_auto_f", error, 0, total_error) - - ! PRINT*,c_associated(f_ptr1) - - ALLOCATE(ptr_data(1:2)) - ptr_data = 0 - array_shape(1) = 2 - CALL C_F_POINTER(f_ptr1, ptr_data, array_shape) - - ! ptr_data => f_ptr1(1) - - ! PRINT*,ptr_data(1) - -!!$ if(old_data != NULL) -!!$ TEST_ERROR; -!!$#ifdef H5_USE_16_API -!!$ if (old_func != (H5E_auto_t)H5Eprint) -!!$ TEST_ERROR; -!!$#else H5_USE_16_API -!!$ if (old_func != (H5E_auto2_t)H5Eprint2) -!!$ TEST_ERROR; -!!$#endif H5_USE_16_API - - - ! set the customized error handling routine - func = c_funloc(my_hdf5_error_handler_nodata) - ! set the data sent to the customized routine as null - f_ptr = C_NULL_PTR - ! turn on automatic printing, and use a custom error routine with no input data - CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr) - - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - CALL verify("h5dcreate_f", error, -1, total_error) - - - ! turn on automatic printing with h5eprint_f which prints an error stack in the default manner. - - ! func = c_funloc(h5eprint_f) - ! CALL H5Eset_auto_f(0, error, H5E_DEFAULT_F, func, C_NULL_PTR) - - CALL H5Eset_auto_f(0, error) - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - - CALL H5Eset_auto_f(1, error) - CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error) - -END SUBROUTINE test_error - -END MODULE TH5E_F03 diff --git a/fortran/test/tH5F.F90 b/fortran/test/tH5F.F90 new file mode 100644 index 0000000..0b3c275 --- /dev/null +++ b/fortran/test/tH5F.F90 @@ -0,0 +1,782 @@ +!***rh* root/fortran/test/tH5F.f90 +! +! NAME +! tH5F.f90 +! +! FUNCTION +! Basic testing of Fortran H5F APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! mountingtest, reopentest, plisttest, file_close, file_space +! +!***** +! +! 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. + + + +MODULE TH5F + +CONTAINS + + SUBROUTINE mountingtest(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + ! + !the respective filename is "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 + + ! + !general purpose integer + ! + INTEGER :: i, j + + ! + !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 + + ! + !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) + + ! + !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 in hdf5 format + ! + 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" + stop + 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" + stop + 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 h5fopen_f (fix_filename2, H5F_ACC_RDWR_F, file2_id, error) + CALL check("h5fopen_f",error,total_error) + + ! + !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 + 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 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) + + 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) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + 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 + 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 + + ! + !Initialize FORTRAN predifined datatypes + ! +! CALL h5init_types_f(error) +! CALL check("h5init_types_f",error,total_error) + + + ! + !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" + stop + 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) + + ! + !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 occured" + 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 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) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + 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 + + ! + !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" + stop + 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" + stop + 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) + + 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 plisttest + + +! +! The following subroutine tests h5pget(set)_fclose_degree_f +! + + SUBROUTINE file_close(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + 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 :: 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" + stop + 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) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + 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 + + 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" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error) + CALL check("h5fcreate_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. 0) 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. 0) 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. 0) then + total_error = total_error + 1 + write(*,*) "3: Wrong amount of free space reported, ", free_space + endif + + CALL h5fclose_f(fid, 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 file_space + + +END MODULE TH5F diff --git a/fortran/test/tH5F.f90 b/fortran/test/tH5F.f90 deleted file mode 100644 index 0b3c275..0000000 --- a/fortran/test/tH5F.f90 +++ /dev/null @@ -1,782 +0,0 @@ -!***rh* root/fortran/test/tH5F.f90 -! -! NAME -! tH5F.f90 -! -! FUNCTION -! Basic testing of Fortran H5F APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! mountingtest, reopentest, plisttest, file_close, file_space -! -!***** -! -! 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. - - - -MODULE TH5F - -CONTAINS - - SUBROUTINE mountingtest(cleanup, total_error) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - ! - !the respective filename is "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 - - ! - !general purpose integer - ! - INTEGER :: i, j - - ! - !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 - - ! - !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) - - ! - !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 in hdf5 format - ! - 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" - stop - 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" - stop - 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 h5fopen_f (fix_filename2, H5F_ACC_RDWR_F, file2_id, error) - CALL check("h5fopen_f",error,total_error) - - ! - !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 - 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 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) - - 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) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - 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 - 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 - - ! - !Initialize FORTRAN predifined datatypes - ! -! CALL h5init_types_f(error) -! CALL check("h5init_types_f",error,total_error) - - - ! - !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" - stop - 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) - - ! - !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 occured" - 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 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) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - 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 - - ! - !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" - stop - 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" - stop - 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) - - 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 plisttest - - -! -! The following subroutine tests h5pget(set)_fclose_degree_f -! - - SUBROUTINE file_close(cleanup, total_error) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - 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 :: 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" - stop - 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) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - 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 - - 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" - stop - endif - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error) - CALL check("h5fcreate_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. 0) 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. 0) 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. 0) then - total_error = total_error + 1 - write(*,*) "3: Wrong amount of free space reported, ", free_space - endif - - CALL h5fclose_f(fid, 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 file_space - - -END MODULE TH5F diff --git a/fortran/test/tH5F_F03.F90 b/fortran/test/tH5F_F03.F90 new file mode 100644 index 0000000..9e23d19 --- /dev/null +++ b/fortran/test/tH5F_F03.F90 @@ -0,0 +1,179 @@ +!****h* root/fortran/test/tH5F_F03.f90 +! +! NAME +! tH5F_F03.f90 +! +! FUNCTION +! Test FORTRAN HDF5 H5F 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests the H5F APIs functionalities of: +! h5fget_file_image_f +! +! CONTAINS SUBROUTINES +! test_get_file_image +! +!***** + +! ***************************************** +! *** H 5 F T E S T S +! ***************************************** + +MODULE TH5F_F03 + + USE HDF5 + USE TH5_MISC + USE TH5_MISC_GEN + USE ISO_C_BINDING + +CONTAINS + +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 :: i, file_sz + 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, itmp_b ! General purpose integers + 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 + + ! 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("tget_file_image.h5", 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) = 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='tget_file_image.h5', 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='tget_file_image.h5', 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_F03 diff --git a/fortran/test/tH5F_F03.f90 b/fortran/test/tH5F_F03.f90 deleted file mode 100644 index 9e23d19..0000000 --- a/fortran/test/tH5F_F03.f90 +++ /dev/null @@ -1,179 +0,0 @@ -!****h* root/fortran/test/tH5F_F03.f90 -! -! NAME -! tH5F_F03.f90 -! -! FUNCTION -! Test FORTRAN HDF5 H5F 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! NOTES -! Tests the H5F APIs functionalities of: -! h5fget_file_image_f -! -! CONTAINS SUBROUTINES -! test_get_file_image -! -!***** - -! ***************************************** -! *** H 5 F T E S T S -! ***************************************** - -MODULE TH5F_F03 - - USE HDF5 - USE TH5_MISC - USE TH5_MISC_GEN - USE ISO_C_BINDING - -CONTAINS - -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 :: i, file_sz - 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, itmp_b ! General purpose integers - 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 - - ! 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("tget_file_image.h5", 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) = 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='tget_file_image.h5', 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='tget_file_image.h5', 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_F03 diff --git a/fortran/test/tH5G.F90 b/fortran/test/tH5G.F90 new file mode 100644 index 0000000..2ba174c --- /dev/null +++ b/fortran/test/tH5G.F90 @@ -0,0 +1,263 @@ +!****h* root/fortran/test/tH5G.f90 +! +! NAME +! tH5G.f90 +! +! FUNCTION +! Basic testing of Fortran H5G APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! group_test +! +!***** + +MODULE TH5G + +CONTAINS + + SUBROUTINE group_test(cleanup, total_error) + +! This subroutine tests following functionalities: +! h5gcreate_f, h5gopen_f, h5gclose_f, (?)h5gget_obj_info_idx_f, h5gn_members_f +! h5glink(2)_f, h5gunlink_f, h5gmove(2)_f, h5gget_linkval_f, h5gset_comment_f, +! h5gget_comment_f + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=5), PARAMETER :: filename = "gtest" !File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=33), PARAMETER :: comment = "Testing the group functionalities" + ! comment for this file + CHARACTER(LEN=7), PARAMETER :: groupname1 = "MyGroup" ! Group name + CHARACTER(LEN=16), PARAMETER :: groupname2 = "/MyGroup/Group_A" + CHARACTER(LEN=9), PARAMETER :: linkname1 = "hardlink1" + CHARACTER(LEN=9), PARAMETER :: linkname2 = "hardlink2" + CHARACTER(LEN=9), PARAMETER :: linkname3 = "softlink1" + CHARACTER(LEN=9), PARAMETER :: linkname4 = "softlink2" + CHARACTER(LEN=12), PARAMETER :: linkname5 = "newsoftlink2" + + CHARACTER(LEN=13), PARAMETER :: dsetname1 = "MyGroup/dset1" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! dataset name + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: group1_id ! Group identifier + INTEGER(HID_T) :: group2_id ! Group identifier + INTEGER(HID_T) :: dset1_id ! Dataset identifier + INTEGER(HID_T) :: dset2_id ! Dataset identifier + INTEGER(HID_T) :: dsetnew_id ! Dataset identifier + INTEGER(HID_T) :: dspace_id ! Data space identifier + + INTEGER, DIMENSION(1) :: dset1_data = 34 ! Data value + INTEGER, DIMENSION(1) :: dset2_data = 98 ! Data value + INTEGER(HSIZE_T), DIMENSION(1) :: dims = 1 ! Datasets dimensions + INTEGER :: rank = 1 ! Datasets rank + INTEGER :: error ! Error flag + INTEGER(SIZE_T) :: namesize = 100 !size for symbolic object + CHARACTER(LEN=100) :: name !name to put symbolic object + CHARACTER(LEN=100) :: commentout !comment to the file + INTEGER :: nmembers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + ! + ! Create the file. + ! + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + ! + ! Create a group named "/MyGroup" in the file. + ! + CALL h5gcreate_f(file_id, groupname1, group1_id, error) + CALL check("h5gcreate_f",error,total_error) + + ! + ! Create a group named "/MyGroup/Group_A" in the file. + ! + CALL h5gcreate_f(file_id, groupname2, group2_id, error) + CALL check("h5gcreate_f",error,total_error) + ! + !Create data space for the dataset. + ! + CALL h5screate_simple_f(rank, dims, dspace_id, error) + CALL check("h5screate_simple_f",error,total_error) + ! + ! create dataset in the file. + ! + CALL h5dcreate_f(file_id, dsetname1, H5T_NATIVE_INTEGER, dspace_id, & + dset1_id, error) + CALL check("h5dcreate_f",error,total_error) + + ! + ! Write data_in to dataset1 + ! + data_dims(1) = 1 + CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, dset1_data, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + + ! + ! create dataset2 in the Group_A. + ! + CALL h5dcreate_f(group2_id, dsetname2, H5T_NATIVE_INTEGER, dspace_id, & + dset2_id, error) + CALL check("h5dcreate_f",error,total_error) + + ! + ! Write data_in to dataset2 + ! + CALL h5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, dset2_data, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + + ! + !Create a hard link to the group1 + ! + CALL h5glink_f(file_id, H5G_LINK_HARD_F, groupname1, linkname1, error) + CALL check("h5glink_f",error,total_error) + ! + !Create a hard link to the group2 + ! + CALL h5glink2_f(file_id, groupname2, H5G_LINK_HARD_F, file_id, linkname2, error) + CALL check("h5glink2_f",error,total_error) + ! + !Create a soft link to dataset11 + ! + CALL h5glink_f(file_id, H5G_LINK_SOFT_F, dsetname1, linkname3, error) + CALL check("h5glink_f",error,total_error) + ! + !Create a soft link to dataset2 + ! + CALL h5glink_f(file_id, H5G_LINK_SOFT_F, dsetname2, linkname4, error) + CALL check("h5glink_f",error,total_error) + ! + !close group1 + ! + CALL h5gclose_f(group1_id, error) + CALL check("h5gclose_f", error, total_error) + ! + !reopen group1 + ! + CALL h5gopen_f(file_id, groupname1, group1_id, error) + CALL check("h5gopen_f", error, total_error) + ! + !get obj info of group1 + ! +! CALL h5gget_obj_info_idx_f(file_id, linkname1, 2, name, obj_type, error) +! CALL check("h5gget_obj_info_idx_f", error, total_error) +! XXX: Fix problems with H5G_LINK_F! - QAK +! if (obj_type .ne. H5G_LINK_F) then +! write(*,*) "got object ", name, " type error ", obj_type +! total_error = total_error +1 +! end if + ! + !Get number of members in the group + ! + CALL h5gn_members_f(file_id, groupname1, nmembers, error) + CALL check("h5gn_members_f",error,total_error) + if (nmembers .ne. 2) then + write(*,*) "got nmembers ", nmembers, " is wrong" + total_error = total_error +1 + end if + ! + !Get the name of a symbolic name + ! + CALL h5gget_linkval_f(file_id, linkname3, namesize, name, error) + CALL check("h5gget_linkval_f",error,total_error) + if ( name(1:13) .ne. dsetname1) then + write(*,*) "got symbolic name ", name, " is wrong" + total_error = total_error +1 + end if + ! + !move softlink2 to newsoftlink2 + ! + CALL h5gmove_f(file_id, linkname4, linkname5, error) + CALL check("h5gmove_f",error,total_error) + ! + !Get the name of the moved symbolic name + ! + CALL h5gget_linkval_f(file_id, linkname5, namesize, name, error) + CALL check("h5gget_linkval_f",error,total_error) + if ( name(1:5) .ne. dsetname2) then + write(*,*) "got symbolic name ", name, " is wrong" + total_error = total_error +1 + end if + + ! + !Unlink the moved symbolic link + ! + CALL h5gunlink_f(file_id, linkname5, error) + CALL check("h5gunlink_f", error, total_error) + + + ! + !set the comment of dataset1 to comment + ! + CALL h5gset_comment_f(file_id, dsetname1, comment, error) + CALL check("h5gset_comment_f", error, total_error) + ! + !get the comment of dataset1 + ! + CALL h5gget_comment_f(file_id, dsetname1,namesize, commentout, error) + CALL check("h5gget_comment_f", error, total_error) + if ( commentout(1:33) .ne. comment) then + write(*,*) "got comment ", commentout, " is wrong" + total_error = total_error +1 + end if + ! + ! Move dataset1 to gourp2_id location + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5gmove2_f(file_id, dsetname1, group2_id, "dset1", error) + CALL check("h5gmove2_f", error, total_error) + ! + ! Open dataset from the new location + ! + Call h5dopen_f(file_id, "/MyGroup/Group_A/dset1" , dsetnew_id, error) + CALL check("h5dopen_f",error, total_error) + ! + !release all the resources + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + CALL h5gclose_f(group1_id, error) + CALL check("h5gclose_f", error, total_error) + CALL h5gclose_f(group2_id, error) + CALL check("h5gclose_f", error, total_error) + CALL h5dclose_f(dset2_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5dclose_f(dsetnew_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5sclose_f(dspace_id, error) + CALL check("h5sclose_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 group_test + +END MODULE TH5G diff --git a/fortran/test/tH5G.f90 b/fortran/test/tH5G.f90 deleted file mode 100644 index 2ba174c..0000000 --- a/fortran/test/tH5G.f90 +++ /dev/null @@ -1,263 +0,0 @@ -!****h* root/fortran/test/tH5G.f90 -! -! NAME -! tH5G.f90 -! -! FUNCTION -! Basic testing of Fortran H5G APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! group_test -! -!***** - -MODULE TH5G - -CONTAINS - - SUBROUTINE group_test(cleanup, total_error) - -! This subroutine tests following functionalities: -! h5gcreate_f, h5gopen_f, h5gclose_f, (?)h5gget_obj_info_idx_f, h5gn_members_f -! h5glink(2)_f, h5gunlink_f, h5gmove(2)_f, h5gget_linkval_f, h5gset_comment_f, -! h5gget_comment_f - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=5), PARAMETER :: filename = "gtest" !File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=33), PARAMETER :: comment = "Testing the group functionalities" - ! comment for this file - CHARACTER(LEN=7), PARAMETER :: groupname1 = "MyGroup" ! Group name - CHARACTER(LEN=16), PARAMETER :: groupname2 = "/MyGroup/Group_A" - CHARACTER(LEN=9), PARAMETER :: linkname1 = "hardlink1" - CHARACTER(LEN=9), PARAMETER :: linkname2 = "hardlink2" - CHARACTER(LEN=9), PARAMETER :: linkname3 = "softlink1" - CHARACTER(LEN=9), PARAMETER :: linkname4 = "softlink2" - CHARACTER(LEN=12), PARAMETER :: linkname5 = "newsoftlink2" - - CHARACTER(LEN=13), PARAMETER :: dsetname1 = "MyGroup/dset1" ! Dataset name - CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! dataset name - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: group1_id ! Group identifier - INTEGER(HID_T) :: group2_id ! Group identifier - INTEGER(HID_T) :: dset1_id ! Dataset identifier - INTEGER(HID_T) :: dset2_id ! Dataset identifier - INTEGER(HID_T) :: dsetnew_id ! Dataset identifier - INTEGER(HID_T) :: dspace_id ! Data space identifier - - INTEGER, DIMENSION(1) :: dset1_data = 34 ! Data value - INTEGER, DIMENSION(1) :: dset2_data = 98 ! Data value - INTEGER(HSIZE_T), DIMENSION(1) :: dims = 1 ! Datasets dimensions - INTEGER :: rank = 1 ! Datasets rank - INTEGER :: error ! Error flag - INTEGER(SIZE_T) :: namesize = 100 !size for symbolic object - CHARACTER(LEN=100) :: name !name to put symbolic object - CHARACTER(LEN=100) :: commentout !comment to the file - INTEGER :: nmembers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - ! - ! Create the file. - ! - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - if (error .ne. 0) then - write(*,*) "Cannot modify filename" - stop - endif - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - ! - ! Create a group named "/MyGroup" in the file. - ! - CALL h5gcreate_f(file_id, groupname1, group1_id, error) - CALL check("h5gcreate_f",error,total_error) - - ! - ! Create a group named "/MyGroup/Group_A" in the file. - ! - CALL h5gcreate_f(file_id, groupname2, group2_id, error) - CALL check("h5gcreate_f",error,total_error) - ! - !Create data space for the dataset. - ! - CALL h5screate_simple_f(rank, dims, dspace_id, error) - CALL check("h5screate_simple_f",error,total_error) - ! - ! create dataset in the file. - ! - CALL h5dcreate_f(file_id, dsetname1, H5T_NATIVE_INTEGER, dspace_id, & - dset1_id, error) - CALL check("h5dcreate_f",error,total_error) - - ! - ! Write data_in to dataset1 - ! - data_dims(1) = 1 - CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, dset1_data, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - - ! - ! create dataset2 in the Group_A. - ! - CALL h5dcreate_f(group2_id, dsetname2, H5T_NATIVE_INTEGER, dspace_id, & - dset2_id, error) - CALL check("h5dcreate_f",error,total_error) - - ! - ! Write data_in to dataset2 - ! - CALL h5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, dset2_data, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - - ! - !Create a hard link to the group1 - ! - CALL h5glink_f(file_id, H5G_LINK_HARD_F, groupname1, linkname1, error) - CALL check("h5glink_f",error,total_error) - ! - !Create a hard link to the group2 - ! - CALL h5glink2_f(file_id, groupname2, H5G_LINK_HARD_F, file_id, linkname2, error) - CALL check("h5glink2_f",error,total_error) - ! - !Create a soft link to dataset11 - ! - CALL h5glink_f(file_id, H5G_LINK_SOFT_F, dsetname1, linkname3, error) - CALL check("h5glink_f",error,total_error) - ! - !Create a soft link to dataset2 - ! - CALL h5glink_f(file_id, H5G_LINK_SOFT_F, dsetname2, linkname4, error) - CALL check("h5glink_f",error,total_error) - ! - !close group1 - ! - CALL h5gclose_f(group1_id, error) - CALL check("h5gclose_f", error, total_error) - ! - !reopen group1 - ! - CALL h5gopen_f(file_id, groupname1, group1_id, error) - CALL check("h5gopen_f", error, total_error) - ! - !get obj info of group1 - ! -! CALL h5gget_obj_info_idx_f(file_id, linkname1, 2, name, obj_type, error) -! CALL check("h5gget_obj_info_idx_f", error, total_error) -! XXX: Fix problems with H5G_LINK_F! - QAK -! if (obj_type .ne. H5G_LINK_F) then -! write(*,*) "got object ", name, " type error ", obj_type -! total_error = total_error +1 -! end if - ! - !Get number of members in the group - ! - CALL h5gn_members_f(file_id, groupname1, nmembers, error) - CALL check("h5gn_members_f",error,total_error) - if (nmembers .ne. 2) then - write(*,*) "got nmembers ", nmembers, " is wrong" - total_error = total_error +1 - end if - ! - !Get the name of a symbolic name - ! - CALL h5gget_linkval_f(file_id, linkname3, namesize, name, error) - CALL check("h5gget_linkval_f",error,total_error) - if ( name(1:13) .ne. dsetname1) then - write(*,*) "got symbolic name ", name, " is wrong" - total_error = total_error +1 - end if - ! - !move softlink2 to newsoftlink2 - ! - CALL h5gmove_f(file_id, linkname4, linkname5, error) - CALL check("h5gmove_f",error,total_error) - ! - !Get the name of the moved symbolic name - ! - CALL h5gget_linkval_f(file_id, linkname5, namesize, name, error) - CALL check("h5gget_linkval_f",error,total_error) - if ( name(1:5) .ne. dsetname2) then - write(*,*) "got symbolic name ", name, " is wrong" - total_error = total_error +1 - end if - - ! - !Unlink the moved symbolic link - ! - CALL h5gunlink_f(file_id, linkname5, error) - CALL check("h5gunlink_f", error, total_error) - - - ! - !set the comment of dataset1 to comment - ! - CALL h5gset_comment_f(file_id, dsetname1, comment, error) - CALL check("h5gset_comment_f", error, total_error) - ! - !get the comment of dataset1 - ! - CALL h5gget_comment_f(file_id, dsetname1,namesize, commentout, error) - CALL check("h5gget_comment_f", error, total_error) - if ( commentout(1:33) .ne. comment) then - write(*,*) "got comment ", commentout, " is wrong" - total_error = total_error +1 - end if - ! - ! Move dataset1 to gourp2_id location - ! - CALL h5dclose_f(dset1_id, error) - CALL check("h5dclose_f", error, total_error) - - CALL h5gmove2_f(file_id, dsetname1, group2_id, "dset1", error) - CALL check("h5gmove2_f", error, total_error) - ! - ! Open dataset from the new location - ! - Call h5dopen_f(file_id, "/MyGroup/Group_A/dset1" , dsetnew_id, error) - CALL check("h5dopen_f",error, total_error) - ! - !release all the resources - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - CALL h5gclose_f(group1_id, error) - CALL check("h5gclose_f", error, total_error) - CALL h5gclose_f(group2_id, error) - CALL check("h5gclose_f", error, total_error) - CALL h5dclose_f(dset2_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5dclose_f(dsetnew_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5sclose_f(dspace_id, error) - CALL check("h5sclose_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 group_test - -END MODULE TH5G diff --git a/fortran/test/tH5G_1_8.F90 b/fortran/test/tH5G_1_8.F90 new file mode 100644 index 0000000..ddc3736 --- /dev/null +++ b/fortran/test/tH5G_1_8.F90 @@ -0,0 +1,2126 @@ +!****h* root/fortran/test/tH5G_1_8.f90 +! +! NAME +! tH5G_1_8.f90 +! +! FUNCTION +! Basic testing of Fortran H5G APIs introduced in 1.8. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! group_test, group_info, timestamps, mklinks, test_move_preserves, lifecycle +! cklinks, delete_by_idx, link_info_by_idx_check, test_lcpl, objcopy, +! lapl_nlinks +! +!***** + +MODULE TH5G_1_8 + + USE HDF5 + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +SUBROUTINE group_test(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: fapl, fapl2, my_fapl ! File access property lists + + INTEGER :: error, ret_total_error + +! WRITE(*,*) "TESTING GROUPS" + CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error) + CALL check("H5Pcreate_f",error, total_error) + + ! Copy the file access property list + CALL H5Pcopy_f(fapl, fapl2, error) + CALL check("H5Pcopy_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(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) + CALL check("H5Pset_libver_bounds_f",error, total_error) + + ! Check for FAPL to USE + my_fapl = fapl2 + + ret_total_error = 0 + CALL mklinks(fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing building a file with assorted links', & + total_error) + + ret_total_error = 0 + CALL cklinks(fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing links are correct and building assorted links', & + total_error) + + ret_total_error = 0 + CALL group_info(cleanup, fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing create group with creation order indices, test querying group info', & + total_error) + +! CALL ud_hard_links(fapl2,total_error) + ret_total_error = 0 + CALL timestamps(cleanup, fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing disabling tracking timestamps for an object', & + total_error) + + ret_total_error = 0 + CALL test_move_preserves(fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing moving and renaming links preserves their properties', & + total_error) + + ret_total_error = 0 + CALL delete_by_idx(cleanup,fapl2,ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing deleting links by index', & + total_error) + + ret_total_error = 0 + CALL test_lcpl(cleanup, fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing link creation property lists', & + total_error) + + ret_total_error = 0 + CALL objcopy(fapl, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing object copy', & + total_error) + + ret_total_error = 0 + CALL lifecycle(cleanup, fapl2, ret_total_error) + CALL write_test_status(ret_total_error, & + ' Testing adding links to a group follow proper "lifecycle"', & + total_error) + + IF(cleanup) CALL h5_cleanup_f("TestLinks", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + +END SUBROUTINE group_test + +!------------------------------------------------------------------------- +! * Function: group_info +! * +! * Purpose: Create a group with creation order indices and test querying +! * group info. +! * +! * Return: Success: 0 +! * Failure: -1 +! * +! * Programmer: Adapted from C test routines by +! * M.S. Breitenfeld +! * February 18, 2008 +! * +! *------------------------------------------------------------------------- +! + +SUBROUTINE group_info(cleanup, fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + + INTEGER(HID_T) :: gcpl_id ! Group creation property list ID + + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + INTEGER :: idx_type ! Type of index to operate on + INTEGER :: order, iorder ! Order within in the index + LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) ! Use index on creation order values + CHARACTER(LEN=6), PARAMETER :: prefix = 'links0' + CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name + INTEGER :: Input1 + INTEGER(HID_T) :: group_id ! Group ID + INTEGER(HID_T) :: soft_group_id ! Group ID for soft links + + INTEGER :: i ! Local index variables + INTEGER :: storage_type ! Type of storage for links in group: + ! H5G_STORAGE_TYPE_COMPACT: Compact storage + ! H5G_STORAGE_TYPE_DENSE: Indexed storage + ! H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure + INTEGER :: nlinks ! Number of links in group + INTEGER :: max_corder ! Current maximum creation order value for group + + INTEGER :: u,v ! Local index variables + CHARACTER(LEN=2) :: chr2 + INTEGER(HID_T) :: group_id2, group_id3 ! Group IDs + CHARACTER(LEN=7) :: objname ! Object name + CHARACTER(LEN=7) :: objname2 ! Object name + CHARACTER(LEN=19) :: valname ! Link value + CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" + CHARACTER(LEN=17), PARAMETER :: CORDER_SOFT_GROUP_NAME = "corder_soft_group" + INTEGER(HID_T) :: file_id ! File ID + INTEGER :: error ! Generic return value + LOGICAL :: mounted + LOGICAL :: cleanup + + ! Create group creation property list + CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) + CALL check("H5Pcreate_f", error, total_error) + + ! Query the group creation properties + CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) + CALL check("H5Pget_link_phase_change_f", error, total_error) + + ! Loop over operating on different indices on link fields + DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F + ! Loop over operating in different orders + DO iorder = H5_ITER_INC_F, H5_ITER_NATIVE_F + ! Loop over using index for creation order value + DO i = 1, 2 + ! Print appropriate test message + IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN + IF(iorder == H5_ITER_INC_F)THEN + order = H5_ITER_INC_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" +!!$ ENDIF + ELSE IF (iorder == H5_ITER_DEC_F) THEN + order = H5_ITER_DEC_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" +!!$ ENDIF + ELSE + order = H5_ITER_NATIVE_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" +!!$ ENDIF + ENDIF + ELSE + IF(iorder == H5_ITER_INC_F)THEN + order = H5_ITER_INC_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" +!!$ ENDIF + ELSE IF (iorder == H5_ITER_DEC_F) THEN + order = H5_ITER_DEC_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" +!!$ ENDIF + ELSE + order = H5_ITER_NATIVE_F +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" +!!$ ENDIF + ENDIF + END IF + + ! Create file + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) + CALL check("H5Fcreate_f", error, total_error) + + ! Set creation order tracking & indexing on group + IF(use_index(i))THEN + Input1 = H5P_CRT_ORDER_INDEXED_F + ELSE + Input1 = 0 + ENDIF + CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) + CALL check("H5Pset_link_creation_order_f", error, total_error) + + ! Create group with creation order tracking on + CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) + CALL check("H5Gcreate_f", error, total_error) + + ! Create group with creation order tracking on for soft links + CALL H5Gcreate_f(file_id, CORDER_SOFT_GROUP_NAME, soft_group_id, error, & + OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) + CALL check("H5Gcreate_f", error, total_error) + + ! Check for out of bound query by index on empty group, should fail + CALL H5Gget_info_by_idx_f(group_id, ".", H5_INDEX_NAME_F, order, INT(0,HSIZE_T), & + storage_type, nlinks, max_corder, error) + CALL verify("H5Gget_info_by_idx_f", error, -1, total_error) + + ! Create several links, up to limit of compact form + DO u = 0, max_compact-1 + + ! Make name for link + WRITE(chr2,'(I2.2)') u + objname = 'fill '//chr2 + + ! Create hard link, with group object + CALL H5Gcreate_f(group_id, objname, group_id2, error, OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) + CALL check("H5Gcreate_f", error, total_error) + + ! Retrieve group's information + CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error, mounted) + CALL check("H5Gget_info_f", error, total_error) + + ! Check (new/empty) group's information + CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_f", max_corder, 0, total_error) + CALL verify("H5Gget_info_f", nlinks, 0, total_error) + CALL verify("H5Gget_info_f.mounted", mounted,.FALSE.,total_error) + + ! Retrieve group's information + CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error, mounted=mounted) + CALL check("H5Gget_info_by_name_f", error, total_error) + + ! Check (new/empty) group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f", max_corder, 0, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, 0, total_error) + CALL verify("H5Gget_info_by_name_f.mounted", mounted,.FALSE.,total_error) + + ! Retrieve group's information + CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_by_name", error, total_error) + + ! Check (new/empty) group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f", max_corder, 0, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, 0, total_error) + + ! Create objects in new group created + DO v = 0, u + ! Make name for link + WRITE(chr2,'(I2.2)') v + objname2 = 'fill '//chr2 + + ! Create hard link, with group object + CALL H5Gcreate_f(group_id2, objname2, group_id3, error ) + CALL check("H5Gcreate_f", error, total_error) + + ! Close group created + CALL H5Gclose_f(group_id3, error) + CALL check("H5Gclose_f", error, total_error) + ENDDO + + ! Retrieve group's information + CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_f", error, total_error) + + ! Check (new) group's information + CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_f", nlinks, u+1, total_error) + + ! Retrieve group's information + CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_by_name_f", error, total_error) + + ! Check (new) group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f",max_corder, u+1, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) + + ! Retrieve group's information + CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_by_name_f", error, total_error) + + ! Check (new) group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) + + ! Retrieve group's information + IF(order.NE.H5_ITER_NATIVE_F)THEN + IF(order.EQ.H5_ITER_INC_F) THEN + CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(u,HSIZE_T), & + storage_type, nlinks, max_corder, error,lapl_id=H5P_DEFAULT_F, mounted=mounted) + CALL check("H5Gget_info_by_idx_f", error, total_error) + CALL verify("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) + ELSE + CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), & + storage_type, nlinks, max_corder, error, mounted=mounted) + CALL verify("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) + CALL check("H5Gget_info_by_idx_f", error, total_error) + ENDIF + ! Check (new) group's information + CALL verify("H5Gget_info_by_idx_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_idx_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_by_idx_f", nlinks, u+1, total_error) + ENDIF + ! Close group created + CALL H5Gclose_f(group_id2, error) + CALL check("H5Gclose_f", error, total_error) + + ! Retrieve main group's information + CALL H5Gget_info_f(group_id, storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_f", error, total_error) + + ! Check main group's information + CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_f", nlinks, u+1, total_error) + + ! Retrieve main group's information, by name + CALL H5Gget_info_by_name_f(file_id, CORDER_GROUP_NAME, storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_by_name_f", error, total_error) + + ! Check main group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) + + ! Retrieve main group's information, by name + CALL H5Gget_info_by_name_f(group_id, ".", storage_type, nlinks, max_corder, error, H5P_DEFAULT_F) + CALL check("H5Gget_info_by_name_f", error, total_error) + + ! Check main group's information + CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) + + ! Create soft link in another group, to objects in main group + valname = CORDER_GROUP_NAME//objname + + CALL H5Lcreate_soft_f(valname, soft_group_id, objname, error, H5P_DEFAULT_F, H5P_DEFAULT_F) + + ! Retrieve soft link group's information, by name + CALL H5Gget_info_f(soft_group_id, storage_type, nlinks, max_corder, error) + CALL check("H5Gget_info_f", error, total_error) + + ! Check soft link group's information + CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) + CALL verify("H5Gget_info_f", max_corder, u+1, total_error) + CALL verify("H5Gget_info_f", nlinks, u+1, total_error) + ENDDO + + ! Close the groups + + CALL H5Gclose_f(group_id, error) + CALL check("H5Gclose_f", error, total_error) + CALL H5Gclose_f(soft_group_id, error) + CALL check("H5Gclose_f", error, total_error) + + ! Close the file + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + ENDDO + ENDDO + ENDDO + + ! Free resources + CALL H5Pclose_f(gcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + + END SUBROUTINE group_info + +!------------------------------------------------------------------------- +! * Function: timestamps +! * +! * Purpose: Verify that disabling tracking timestamps for an object +! * works correctly +! * +! * +! * Programmer: M.S. Breitenfeld +! * February 20, 2008 +! * +! *------------------------------------------------------------------------- +! + + SUBROUTINE timestamps(cleanup, fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + + INTEGER(HID_T) :: file_id ! File ID + INTEGER(HID_T) :: group_id ! Group ID + INTEGER(HID_T) :: group_id2 ! Group ID + INTEGER(HID_T) :: gcpl_id ! Group creation property list ID + INTEGER(HID_T) :: gcpl_id2 ! Group creation property list ID + + CHARACTER(LEN=6), PARAMETER :: prefix = 'links9' + CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name + ! Timestamp macros + CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_1="timestamp1" + CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_2="timestamp2" + LOGICAL :: track_times + LOGICAL :: cleanup + + INTEGER :: error + + ! Print test message +! WRITE(*,*) "timestamps on objects" + + ! Create group creation property list + CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) + CALL check("H5Pcreate_f", error, total_error) + + ! Query the object timestamp setting + CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + + ! Check default timestamp information + CALL verify("H5Pget_obj_track_times",track_times,.TRUE.,total_error) + + ! Set a non-default object timestamp setting + CALL H5Pset_obj_track_times_f(gcpl_id, .FALSE., error) + CALL check("H5Pset_obj_track_times_f", error, total_error) + + ! Query the object timestamp setting + CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + + ! Check default timestamp information + CALL verify("H5Pget_obj_track_times",track_times,.FALSE.,total_error) + + ! Create file + !h5_fixname(FILENAME[0], fapl, filename, sizeof filename); + + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) + CALL check("h5fcreate_f",error,total_error) + + ! Create group with non-default object timestamp setting + CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_1, group_id, error, & + OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id, H5P_DEFAULT_F) + CALL check("h5fcreate_f",error,total_error) + + ! Close the group creation property list + CALL H5Pclose_f(gcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + + ! Create group with default object timestamp setting + CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, & + OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("h5fcreate_f",error,total_error) + + ! Retrieve the new groups' creation properties + CALL H5Gget_create_plist_f(group_id, gcpl_id, error) + CALL check("H5Gget_create_plist", error, total_error) + CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) + CALL check("H5Gget_create_plist", error, total_error) + + ! Query & verify the object timestamp settings + CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + CALL verify("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) + CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + CALL verify("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) + +! Query the object information for each group +! if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR +! if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR + +!!$ Sanity check object information for each group +!!$ if(oinfo.atime != 0) TEST_ERROR +!!$ if(oinfo.mtime != 0) TEST_ERROR +!!$ if(oinfo.ctime != 0) TEST_ERROR +!!$ if(oinfo.btime != 0) TEST_ERROR +!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR +!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR +!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR +!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR +!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR +!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR +!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR +!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR + + ! Close the property lists + CALL H5Pclose_f(gcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(gcpl_id2, error) + CALL check("H5Pclose_f", error, total_error) + + ! Close the groups + CALL H5Gclose_f(group_id, error) + CALL check("H5Gclose_f", error, total_error) + CALL H5Gclose_f(group_id2, error) + CALL check("H5Gclose_f", error, total_error) + + ! Close the file + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + + ! Re-open the file + + CALL h5fopen_f(FileName, H5F_ACC_RDONLY_F, file_id, error, H5P_DEFAULT_F) + CALL check("h5fopen_f",error,total_error) + + ! Open groups + CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_1, group_id, error) ! with no optional param. + CALL check("H5Gopen_f", error, total_error) + CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, H5P_DEFAULT_F) ! with optional param. + CALL check("H5Gopen_f", error, total_error) + + ! Retrieve the new groups' creation properties + CALL H5Gget_create_plist_f(group_id, gcpl_id, error) + CALL check("H5Gget_create_plist", error, total_error) + CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) + CALL check("H5Gget_create_plist", error, total_error) + + ! Query & verify the object timestamp settings + + CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + CALL verify("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) + CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) + CALL check("H5Pget_obj_track_times_f", error, total_error) + CALL verify("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) +!!$ +!!$ Query the object information for each group +!!$ if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR +!!$ if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR +!!$ +!!$ Sanity check object information for each group +!!$ if(oinfo.atime != 0) TEST_ERROR +!!$ if(oinfo.mtime != 0) TEST_ERROR +!!$ if(oinfo.ctime != 0) TEST_ERROR +!!$ if(oinfo.btime != 0) TEST_ERROR +!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR +!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR +!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR +!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR +!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR +!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR +!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR +!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR + + ! Close the property lists + CALL H5Pclose_f(gcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(gcpl_id2, error) + CALL check("H5Pclose_f", error, total_error) + + ! Close the groups + CALL H5Gclose_f(group_id, error) + CALL check("H5Gclose_f", error, total_error) + CALL H5Gclose_f(group_id2, error) + CALL check("H5Gclose_f", error, total_error) + + ! Close the file + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + END SUBROUTINE timestamps + +!------------------------------------------------------------------------- +! * Function: mklinks +! * +! * Purpose: Build a file with assorted links. +! * +! * +! * Programmer: Adapted from C test by: +! * M.S. Breitenfeld +! * +! * Modifications: +! * +! *------------------------------------------------------------------------- +! + + SUBROUTINE mklinks(fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + + INTEGER(HID_T) :: file, scalar, grp, d1 + CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' + INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension + INTEGER :: arank = 1 ! Attribure rank + INTEGER :: error + + INTEGER :: cset ! Indicates the character set used for the link’s name. + INTEGER :: corder ! Specifies the link’s creation order position. + LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. + INTEGER :: link_type ! Specifies the link class: + ! H5L_TYPE_HARD_F - Hard link + ! H5L_TYPE_SOFT_F - Soft link + ! H5L_TYPE_EXTERNAL_F - External link + ! H5L_TYPE_ERROR _F - Error + INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to + INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value + + +! WRITE(*,*) "link creation (w/new group format)" + + ! Create a file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl) + CALL check("mklinks.h5fcreate_f",error,total_error) + CALL h5screate_simple_f(arank, adims2, scalar, error) + CALL check("mklinks.h5screate_simple_f",error,total_error) + + ! Create a group + CALL H5Gcreate_f(file, "grp1", grp, error) + CALL check("H5Gcreate_f", error, total_error) + CALL H5Gclose_f(grp, error) + CALL check("h5gclose_f",error,total_error) + + ! Create a dataset + CALL h5dcreate_f(file, "d1", H5T_NATIVE_INTEGER, scalar, d1, error) + CALL check("h5dcreate_f",error,total_error) + CALL h5dclose_f(d1, error) + CALL check("h5dclose_f",error,total_error) + + ! Create a hard link + CALL H5Lcreate_hard_f(file, "d1", INT(H5L_SAME_LOC_F,HID_T), "grp1/hard", error) + CALL check("H5Lcreate_hard_f", error, total_error) + + ! Create a symbolic link + CALL H5Lcreate_soft_f("/d1", file, "grp1/soft",error) + CALL check("H5Lcreate_soft_f", error, total_error) + + CALL H5Lget_info_f(file, "grp1/soft", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error, H5P_DEFAULT_F) + CALL check("H5Lget_info_f",error,total_error) + +! CALL verify("H5Lget_info_by_idx_f11", f_corder_valid, .TRUE., total_error) + + CALL verify("H5Lget_info_by_idx_f", H5L_TYPE_SOFT_F, link_type, total_error) + CALL verify("H5Lget_info_by_idx_f", cset, H5T_CSET_ASCII_F, total_error) + ! should be '/d1' + NULL character = 4 + CALL verify("H5Lget_info_by_idx_f", INT(val_size), 4, total_error) + + ! Create a symbolic link to something that doesn't exist + + CALL H5Lcreate_soft_f("foobar", file, "grp1/dangle",error) + + ! Create a recursive symbolic link + CALL H5Lcreate_soft_f("/grp1/recursive", file, "/grp1/recursive",error) + + ! Close + CALL h5sclose_f(scalar, error) + CALL check("h5sclose_f",error,total_error) + CALL h5fclose_f(file, error) + CALL check("h5fclose_f",error,total_error) + + END SUBROUTINE mklinks + +!------------------------------------------------------------------------- +! * Function: test_move_preserves +! * +! * Purpose: Tests that moving and renaming links preserves their +! * properties. +! * +! * Programmer: M.S. Breitenfeld +! * March 3, 2008 +! * +! * Modifications: +! * +! *------------------------------------------------------------------------- +! + + SUBROUTINE test_move_preserves(fapl_id, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl_id + + INTEGER(HID_T):: file_id + INTEGER(HID_T):: group_id + INTEGER(HID_T):: fcpl_id ! Group creation property list ID + INTEGER(HID_T):: lcpl_id + !H5O_info_t oinfo; + !H5L_info_t linfo; + INTEGER :: old_cset + INTEGER :: old_corder + !H5T_cset_t old_cset; + !int64_t old_corder; Creation order value of link + !time_t old_modification_time; + !time_t curr_time; + !unsigned crt_order_flags; Status of creation order info for GCPL + !char filename[1024]; + + INTEGER :: crt_order_flags ! Status of creation order info for GCPL + CHARACTER(LEN=12), PARAMETER :: filename = 'TestLinks.h5' + + INTEGER :: cset ! Indicates the character set used for the link’s name. + INTEGER :: corder ! Specifies the link’s creation order position. + LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. + INTEGER :: link_type ! Specifies the link class: + ! H5L_TYPE_HARD_F - Hard link + ! H5L_TYPE_SOFT_F - Soft link + ! H5L_TYPE_EXTERNAL_F - External link + ! H5L_TYPE_ERROR _F - Error + INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to + INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value + + INTEGER :: error + +! WRITE(*,*) "moving and copying links preserves their properties (w/new group format)" + + ! Create a file creation property list with creation order stored for links + ! * in the root group + ! + + CALL H5Pcreate_f(H5P_FILE_CREATE_F, fcpl_id, error) + CALL check("H5Pcreate_f",error, total_error) + + CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) + CALL check("H5Pget_link_creation_order_f",error, total_error) + CALL verify("H5Pget_link_creation_order_f",crt_order_flags,0, total_error) + + CALL H5Pset_link_creation_order_f(fcpl_id, H5P_CRT_ORDER_TRACKED_F, error) + CALL check("H5Pset_link_creation_order_f", error, total_error) + + CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) + CALL check("H5Pget_link_creation_order_f",error, total_error) + CALL verify("H5Pget_link_creation_order_f",crt_order_flags, H5P_CRT_ORDER_TRACKED_F, total_error) + + ! Create file + ! (with creation order tracking for the root group) + + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file_id, error, fcpl_id, fapl_id) + CALL check("h5fcreate_f",error,total_error) + + ! Create a link creation property list with the UTF-8 character encoding + CALL H5Pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) + CALL check("H5Pcreate_f",error, total_error) + + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + + ! Create a group with that lcpl + CALL H5Gcreate_f(file_id, "group", group_id, error,lcpl_id=lcpl_id, gcpl_id=H5P_DEFAULT_F, gapl_id=H5P_DEFAULT_F) + CALL check("H5Gcreate_f", error, total_error) + CALL H5Gclose_f(group_id, error) + CALL check("H5Gclose_f", error, total_error) + + ! Get the group's link's information + CALL H5Lget_info_f(file_id, "group", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error, H5P_DEFAULT_F) + CALL check("H5Lget_info_f",error,total_error) + +! if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR + + old_cset = cset + CALL verify("H5Lget_info_f",old_cset,H5T_CSET_UTF8_F,total_error) + CALL verify("H5Lget_info_f",f_corder_valid,.TRUE.,total_error) + old_corder = corder; + CALL verify("H5Lget_info_f",old_corder,0,total_error) + +! old_modification_time = oinfo.mtime; + +! If this test happens too quickly, the times will all be the same. Make sure the time changes. +! curr_time = HDtime(NULL); +! while(HDtime(NULL) <= curr_time) +! ; + +! Close the file and reopen it + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + +!!$ if((file_id = H5Fopen(filename, H5F_ACC_RDWR, fapl_id)) < 0) TEST_ERROR +!!$ +!!$ Get the link's character set & modification time . They should be unchanged +!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(old_cset != linfo.cset) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(old_corder != linfo.corder) TEST_ERROR +!!$ +!!$ Create a new link to the group. It should have a different creation order value but the same modification time +!!$ if(H5Lcreate_hard(file_id, "group", file_id, "group2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_corder == linfo.corder) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(linfo.corder != 1) TEST_ERROR +!!$ if(linfo.cset != H5T_CSET_ASCII) TEST_ERROR +!!$ +!!$ Copy the first link to a UTF-8 name. +!!$ * Its creation order value should be different, but modification time +!!$ * should not change. +!!$ +!!$ if(H5Lcopy(file_id, "group", file_id, "group_copied", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group_copied", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group_copied", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(linfo.corder != 2) TEST_ERROR +!!$ +!!$ Check that its character encoding is UTF-8 +!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR +!!$ +!!$ Move the link with the default property list. +!!$ if(H5Lmove(file_id, "group_copied", file_id, "group_copied2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group_copied2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group_copied2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(linfo.corder != 3) TEST_ERROR +!!$ +!!$ Check that its character encoding is not UTF-8 +!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR +!!$ +!!$ Check that the original link is unchanged +!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(old_corder != linfo.corder) TEST_ERROR +!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR +!!$ +!!$ Move the first link to a UTF-8 name. +!!$ * Its creation order value will change, but modification time should not +!!$ * change. +!!$ if(H5Lmove(file_id, "group", file_id, "group_moved", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group_moved", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group_moved", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(linfo.corder != 4) TEST_ERROR +!!$ +!!$ Check that its character encoding is UTF-8 +!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR +!!$ +!!$ Move the link again using the default property list. +!!$ if(H5Lmove(file_id, "group_moved", file_id, "group_moved_again", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(H5Oget_info_by_name(file_id, "group_moved_again", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR +!!$ if(H5Lget_info(file_id, "group_moved_again", &linfo, H5P_DEFAULT) < 0) TEST_ERROR +!!$ if(linfo.corder_valid != TRUE) TEST_ERROR +!!$ if(linfo.corder != 5) TEST_ERROR +!!$ +!!$ Check that its character encoding is not UTF-8 +!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR + + ! Close open IDs + CALL H5Pclose_f(fcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(lcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + + ! if(H5Fclose(file_id) < 0) TEST_ERROR + + END SUBROUTINE test_move_preserves + +!------------------------------------------------------------------------- +! * Function: lifecycle +! * +! * Purpose: Test that adding links to a group follow proper "lifecycle" +! * of empty->compact->symbol table->compact->empty. (As group +! * is created, links are added, then links removed) +! * +! * Return: Success: 0 +! * +! * Failure: -1 +! * +! * Programmer: Quincey Koziol +! * Monday, October 17, 2005 +! * +! *------------------------------------------------------------------------- +! +SUBROUTINE lifecycle(cleanup, fapl2, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl2 + INTEGER :: error + + INTEGER, PARAMETER :: NAME_BUF_SIZE =7 + + INTEGER(HID_T) :: fid ! File ID + INTEGER(HID_T) :: gid ! Group ID + INTEGER(HID_T) :: gcpl ! Group creation property list ID + INTEGER(size_t) :: lheap_size_hint ! Local heap size hint + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + INTEGER :: est_num_entries ! Estimated # of entries in group + INTEGER :: est_name_len ! Estimated length of entry name + CHARACTER(LEN=NAME_BUF_SIZE) :: filename = 'fixx.h5' + INTEGER(SIZE_T) :: LIFECYCLE_LOCAL_HEAP_SIZE_HINT = 256 + INTEGER :: LIFECYCLE_MAX_COMPACT = 4 + INTEGER :: LIFECYCLE_MIN_DENSE = 3 + INTEGER :: LIFECYCLE_EST_NUM_ENTRIES = 4 + INTEGER :: LIFECYCLE_EST_NAME_LEN=8 + CHARACTER(LEN=3) :: LIFECYCLE_TOP_GROUP="top" +! These value are taken from H5Gprivate.h + INTEGER :: H5G_CRT_GINFO_MAX_COMPACT = 8 + INTEGER :: H5G_CRT_GINFO_MIN_DENSE = 6 + INTEGER :: H5G_CRT_GINFO_EST_NUM_ENTRIES = 4 + INTEGER :: H5G_CRT_GINFO_EST_NAME_LEN = 8 + logical :: cleanup + +! WRITE(*,*) 'group lifecycle' + + ! Create file + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl2) + CALL check("H5Fcreate_f",error,total_error) + + ! Close file + CALL H5Fclose_f(fid,error) + CALL check("H5Fclose_f",error,total_error) + + ! Get size of file as empty + ! if((empty_size = h5_get_file_size(filename)) < 0) TEST_ERROR + + ! Re-open file + + CALL H5Fopen_f(filename, H5F_ACC_RDWR_F, fid, error,access_prp=fapl2) + CALL check("H5Fopen_f",error,total_error) + + + ! Set up group creation property list + CALL H5Pcreate_f(H5P_GROUP_CREATE_F,gcpl,error) + CALL check("H5Pcreate_f",error,total_error) + + + ! Query default group creation property settings + CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) + CALL check("H5Pget_local_heap_size_hint_f",error,total_error) + CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),0,total_error) + + CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) + CALL check("H5Pget_link_phase_change_f", error, total_error) + CALL verify("H5Pget_link_phase_change_f", max_compact, H5G_CRT_GINFO_MAX_COMPACT,total_error) + CALL verify("H5Pget_link_phase_change_f", min_dense, H5G_CRT_GINFO_MIN_DENSE,total_error) + + + CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) + CALL check("H5Pget_est_link_info_f", error, total_error) + CALL verify("H5Pget_est_link_info_f", est_num_entries, H5G_CRT_GINFO_EST_NUM_ENTRIES,total_error) + CALL verify("H5Pget_est_link_info_f", est_name_len, H5G_CRT_GINFO_EST_NAME_LEN,total_error) + + + ! Set GCPL parameters + + CALL H5Pset_local_heap_size_hint_f(gcpl, LIFECYCLE_LOCAL_HEAP_SIZE_HINT, error) + CALL check("H5Pset_local_heap_size_hint_f", error, total_error) + CALL H5Pset_link_phase_change_f(gcpl, LIFECYCLE_MAX_COMPACT, LIFECYCLE_MIN_DENSE, error) + CALL check("H5Pset_link_phase_change_f", error, total_error) + CALL H5Pset_est_link_info_f(gcpl, LIFECYCLE_EST_NUM_ENTRIES, LIFECYCLE_EST_NAME_LEN, error) + CALL check("H5Pset_est_link_info_f", error, total_error) + + ! Create group for testing lifecycle + + CALL H5Gcreate_f(fid, LIFECYCLE_TOP_GROUP, gid, error, gcpl_id=gcpl) + CALL check("H5Gcreate_f", error, total_error) + + ! Query group creation property settings + + CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) + CALL check("H5Pget_local_heap_size_hint_f",error,total_error) + CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),INT(LIFECYCLE_LOCAL_HEAP_SIZE_HINT),total_error) + + CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) + CALL check("H5Pget_link_phase_change_f", error, total_error) + CALL verify("H5Pget_link_phase_change_f", max_compact, LIFECYCLE_MAX_COMPACT,total_error) + CALL verify("H5Pget_link_phase_change_f", min_dense, LIFECYCLE_MIN_DENSE,total_error) + + CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) + CALL check("H5Pget_est_link_info_f", error, total_error) + CALL verify("H5Pget_est_link_info_f", est_num_entries, LIFECYCLE_EST_NUM_ENTRIES,total_error) + CALL verify("H5Pget_est_link_info_f", est_name_len, LIFECYCLE_EST_NAME_LEN,total_error) + + + + ! Close top group + CALL H5Gclose_f(gid, error) + CALL check("H5Gclose_f", error, total_error) + + ! Unlink top group + + CALL H5Ldelete_f(fid, LIFECYCLE_TOP_GROUP, error) + CALL check("H5Ldelete_f", error, total_error) + + ! Close GCPL + CALL H5Pclose_f(gcpl, error) + CALL check("H5Pclose_f", error, total_error) + + ! Close file + CALL H5Fclose_f(fid,error) + CALL check("H5Fclose_f",error,total_error) + + IF(cleanup) CALL h5_cleanup_f("fixx", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + END SUBROUTINE lifecycle + +!------------------------------------------------------------------------- +! * Function: cklinks +! * +! * Purpose: Open the file created in the first step and check that the +! * links look correct. +! * +! * Return: Success: 0 +! * +! * Failure: -1 +! * +! * Programmer: M.S. Breitenfeld +! * April 14, 2008 +! * +! * Modifications: Modified original C code +! * +! *------------------------------------------------------------------------- +! + + + SUBROUTINE cklinks(fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER :: error + + INTEGER(HID_T) :: file +! H5O_info_t oinfo1, oinfo2; +! H5L_info_t linfo2; + + CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' + +! TYPE(C_PTR) :: linkval + + LOGICAL :: Lexists + + ! Open the file + CALL H5Fopen_f(filename, H5F_ACC_RDONLY_F, file, error,access_prp=fapl) + CALL check("H5Fopen_f",error,total_error) + + + ! Hard link +!!$ IF(H5Oget_info_by_name(file, "d1", &oinfo1, H5P_DEFAULT) < 0) FAIL_STACK_ERROR +!!$ IF(H5Oget_info_by_name(file, "grp1/hard", &oinfo2, H5P_DEFAULT) < 0) FAIL_STACK_ERROR +!!$ IF(H5O_TYPE_DATASET != oinfo2.type) { +!!$ H5_FAILED(); +!!$ printf(" %d: Unexpected object type should have been a dataset\n", __LINE__); +!!$ TEST_ERROR +!!$ } end if +!!$ if(H5F_addr_ne(oinfo1.addr, oinfo2.addr)) { +!!$ H5_FAILED(); +!!$ puts(" Hard link test failed. Link seems not to point to the "); +!!$ puts(" expected file location."); +!!$ TEST_ERROR +!!$ } end if + + + CALL H5Lexists_f(file,"d1",Lexists, error) + CALL verify("H5Lexists", Lexists,.TRUE.,total_error) + + CALL H5Lexists_f(file,"grp1/hard",Lexists, error) + CALL verify("H5Lexists", Lexists,.TRUE.,total_error) + + ! Cleanup + CALL H5Fclose_f(file,error) + CALL check("H5Fclose_f",error,total_error) + +END SUBROUTINE cklinks + + +!------------------------------------------------------------------------- +! * Function: delete_by_idx +! * +! * Purpose: Create a group with creation order indices and test deleting +! * links by index. +! * +! * Return: Total error +! * +! * C Programmer: Quincey Koziol +! * Tuesday, November 14, 2006 +! * +! * Adapted to FORTRAN: M.S. Breitenfeld +! * March 3, 2008 +! * +! *------------------------------------------------------------------------- +! +SUBROUTINE delete_by_idx(cleanup, fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + + INTEGER(HID_T) :: file_id ! File ID + INTEGER(HID_T) :: group_id ! Group ID + INTEGER(HID_T) :: gcpl_id ! Group creation property list ID + + INTEGER :: idx_type ! Type of index to operate on + LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) + ! Use index on creation order values + INTEGER :: max_compact ! Maximum # of links to store in group compactly + INTEGER :: min_dense ! Minimum # of links to store in group "densely" + + CHARACTER(LEN=7) :: objname ! Object name + CHARACTER(LEN=8) :: filename = 'file0.h5' ! File name + CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" + + LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER(SIZE_T) :: val_size + INTEGER :: link_type + INTEGER(HADDR_T) :: address + + INTEGER :: u ! Local index variable + INTEGER :: Input1, i + INTEGER(HID_T) :: group_id2 + INTEGER(HID_T) :: grp + INTEGER :: iorder ! Order within in the index + CHARACTER(LEN=2) :: chr2 + INTEGER :: error + INTEGER :: id_type + ! + ! + ! + CHARACTER(LEN=80) :: fix_filename1 + CHARACTER(LEN=80) :: fix_filename2 + INTEGER(HSIZE_T) :: htmp + + LOGICAL :: cleanup + + DO i = 1, 80 + fix_filename1(i:i) = " " + fix_filename2(i:i) = " " + ENDDO + + ! Loop over operating on different indices on link fields + DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F + ! Loop over operating in different orders + DO iorder = H5_ITER_INC_F, H5_ITER_DEC_F + ! Loop over using index for creation order value + DO i = 1, 2 + ! Print appropriate test message +!!$ IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN +!!$ IF(iorder == H5_ITER_INC_F)THEN +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/o creation order index" +!!$ ENDIF +!!$ ELSE +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/o creation order index" +!!$ ENDIF +!!$ ENDIF +!!$ ELSE +!!$ IF(iorder == H5_ITER_INC_F)THEN +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/o creation order index" +!!$ ENDIF +!!$ ELSE +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/creation order index" +!!$ ELSE +!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/o creation order index" +!!$ ENDIF +!!$ ENDIF +!!$ ENDIF + + ! Create file + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, access_prp=fapl) + CALL check("delete_by_idx.H5Fcreate_f", error, total_error) + + ! Create group creation property list + CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) + CALL check("delete_by_idx.H5Pcreate_f", error, total_error) + + ! Set creation order tracking & indexing on group + IF(use_index(i))THEN + Input1 = H5P_CRT_ORDER_INDEXED_F + ELSE + Input1 = 0 + ENDIF + + CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) + CALL check("delete_by_idx.H5Pset_link_creation_order_f", error, total_error) + + ! Create group with creation order tracking on + CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) + CALL check("delete_by_idx.H5Gcreate_f", error, total_error) + + ! Query the group creation properties + CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) + CALL check("delete_by_idx.H5Pget_link_phase_change_f", error, total_error) + + + ! Delete links from one end + + ! Check for deletion on empty group + CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) + CALL verify("delete_by_idx.H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) + ! Create several links, up to limit of compact form + DO u = 0, max_compact-1 + ! Make name for link + WRITE(chr2,'(I2.2)') u + objname = 'fill '//chr2 + + ! Create hard link, with group object + CALL H5Gcreate_f(group_id, objname, group_id2, error) + CALL check("delete_by_idx.H5Gcreate_f", error, total_error) + CALL H5Gclose_f(group_id2, error) + CALL check("delete_by_idx.H5Gclose_f", error, total_error) + + ! Verify link information for new link + CALL link_info_by_idx_check(group_id, objname, u, & + .TRUE., use_index(i), total_error) + ENDDO + + ! Verify state of group (compact) + ! IF(H5G_has_links_test(group_id, NULL) != TRUE) TEST_ERROR + + ! Check for out of bound deletion + htmp =9 +!EP CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(u,HSIZE_T), error) + CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, htmp, error) + CALL verify("H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) + + + ! Delete links from compact group + + DO u = 0, (max_compact - 1) -1 + ! Delete first link in appropriate order + CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) + CALL check("H5Ldelete_by_idx_f", error, total_error) + ! Verify the link information for first link in appropriate order + ! HDmemset(&linfo, 0, sizeof(linfo)); + + CALL H5Lget_info_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), & + link_type, f_corder_valid, corder, cset, address, val_size, error) + + CALL H5Oopen_by_addr_f(group_id, address, grp, error) + CALL check("H5Oopen_by_addr_f", error, total_error) + + CALL H5Iget_type_f(grp, id_type, error) + CALL check("H5Iget_type_f", error, total_error) + + CALL verify("H5Iget_type_f", id_type, H5I_GROUP_F, total_error) + + CALL H5Gclose_f(grp, error) + CALL check("H5Gclose_f", error, total_error) + + CALL verify("H5Lget_info_by_idx_f", f_corder_valid, .TRUE., total_error) + + CALL verify("H5Lget_info_by_idx_f", H5L_TYPE_HARD_F, link_type, total_error) + IF(iorder.EQ.H5_ITER_INC_F)THEN + CALL verify("H5Lget_info_by_idx_f", corder, u+1, total_error) + ELSE + CALL verify("H5Lget_info_by_idx_f", corder, (max_compact - (u + 2)), total_error) + ENDIF + + CALL verify("H5Lget_info_by_idx_f",cset, H5T_CSET_ASCII_F, total_error) + + + + ! Verify the name for first link in appropriate order + ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); +!!$ size_tmp = 20 +!!$ CALL H5Lget_name_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), size_tmp, tmpname, error) +!!$ CALL check("delete_by_idx.H5Lget_name_by_idx_f", error, total_error) +!!$ +!!$ IF(order .EQ. H5_ITER_INC_F)THEN +!!$ WRITE(chr2,'(I2.2)') u + 1 +!!$ ELSE +!!$ WRITE(chr2,'(I2.2)') (max_compact - (u + 2)) +!!$ ENDIF +!!$ objname = 'fill '//chr2 +!!$ PRINT*,objname, tmpname +!!$ CALL verify("delete_by_idx.H5Lget_name_by_idx_f", objname, tmpname, total_error) + ENDDO + + ! Close the group + CALL H5Gclose_f(group_id, error) + CALL check("delete_by_idx.H5Gclose_f", error, total_error) + + ! Close the group creation property list + CALL H5Pclose_f(gcpl_id, error) + CALL check("delete_by_idx.H5Gclose_f", error, total_error) + + ! Close the file + CALL H5Fclose_f(file_id, error) + CALL check("delete_by_idx.H5Gclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f("file0", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + ENDDO + ENDDO + ENDDO + + +END SUBROUTINE delete_by_idx + + + +!------------------------------------------------------------------------- +! * Function: link_info_by_idx_check +! * +! * Purpose: Support routine for link_info_by_idx, to verify the link +! * info is correct for a link +! * +! * Note: This routine assumes that the links have been inserted in the +! * group in alphabetical order. +! * +! * Return: Success: 0 +! * Failure: -1 +! * +! * Programmer: Quincey Koziol +! * Tuesday, November 7, 2006 +! * +! *------------------------------------------------------------------------- +! +SUBROUTINE link_info_by_idx_check(group_id, linkname, n, & + hard_link, use_index, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: group_id + CHARACTER(LEN=*), INTENT(IN) :: linkname + INTEGER, INTENT(IN) :: n + LOGICAL, INTENT(IN) :: hard_link + LOGICAL, INTENT(IN) :: use_index + + LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute + INTEGER :: corder ! Is a positive integer containing the creation order of the attribute + INTEGER :: cset ! Indicates the character set used for the attribute’s name + INTEGER :: link_type + INTEGER(HADDR_T) :: address + INTEGER(SIZE_T) :: val_size ! Indicates the size, in the number of characters, of the attribute + + CHARACTER(LEN=7) :: tmpname ! Temporary link name + CHARACTER(LEN=3) :: tmpname_small ! to small temporary link name + CHARACTER(LEN=10) :: tmpname_big ! to big temporary link name + + CHARACTER(LEN=7) :: valname ! Link value name + CHARACTER(LEN=2) :: chr2 + INTEGER(SIZE_T) :: size_tmp + INTEGER :: error + + ! Make link value for increasing/native order queries + + WRITE(chr2,'(I2.2)') n + valname = 'valn.'//chr2 + + ! Verify the link information for first link, in increasing creation order + ! HDmemset(&linfo, 0, sizeof(linfo)); + CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(0,HSIZE_T), & + link_type, f_corder_valid, corder, cset, address, val_size, error) + CALL check("H5Lget_info_by_idx_f", error, total_error) + CALL verify("H5Lget_info_by_idx_f", corder, 0, total_error) + + ! Verify the link information for new link, in increasing creation order + ! HDmemset(&linfo, 0, sizeof(linfo)); + CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), & + link_type, f_corder_valid, corder, cset, address, val_size, error) + CALL check("H5Lget_info_by_idx_f", error, total_error) + CALL verify("H5Lget_info_by_idx_f", corder, n, total_error) + + ! Verify value for new soft link, in increasing creation order +!!$ IF(hard_link)THEN +!!$ ! HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE); +!!$ +!!$ CALL H5Lget_val_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, n, tmpval, INT(7,SIZE_T),error) +!!$ CALL check("H5Lget_val_by_idx",error,total_error) +!!$ +!!$! IF(HDstrcmp(valname, tmpval)) TEST_ERROR +!!$ ENDIF + + ! Verify the name for new link, in increasing creation order + ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); + + ! The actual size of tmpname should be 7 + + CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_small, error, size_tmp) + CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & + linkname(1:LEN(tmpname_small)), tmpname_small(1:LEN(tmpname_small)), total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) + ! try it with the correct size + CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname, error, size=size_tmp) + CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & + linkname(1:LEN(tmpname)), tmpname(1:LEN(tmpname)), total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) + + CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_big, error, size_tmp) + CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & + linkname(1:7), tmpname_big(1:7), total_error) + CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) + + ! Try with a buffer set to small + + + END SUBROUTINE link_info_by_idx_check + + +!------------------------------------------------------------------------- +! * Function: test_lcpl +! * +! * Purpose: Tests Link Creation Property Lists +! * +! * Return: Success: 0 +! * Failure: number of errors +! * +! * Programmer: M.S. Breitenfeld +! * Modified C routine +! * March 12, 2008 +! * +! * Modifications: +! * +! *------------------------------------------------------------------------- +! + + SUBROUTINE test_lcpl(cleanup, fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + LOGICAL :: cleanup + + INTEGER(HID_T) :: file_id + INTEGER(HID_T) :: group_id + INTEGER(HID_T) :: space_id, data_space + INTEGER(HID_T) :: dset_id + INTEGER(HID_T) :: type_id + INTEGER(HID_T) :: lcpl_id + + INTEGER :: cset ! Indicates the character set used for the link’s name. + INTEGER :: corder ! Specifies the link’s creation order position. + LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. + INTEGER :: link_type ! Specifies the link class: + ! H5L_TYPE_HARD_F - Hard link + ! H5L_TYPE_SOFT_F - Soft link + ! H5L_TYPE_EXTERNAL_F - External link + ! H5L_TYPE_ERROR _F - Error + INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to + INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value + + CHARACTER(LEN=1024) :: filename = 'tempfile.h5' + INTEGER, PARAMETER :: TEST6_DIM1 = 8, TEST6_DIM2 = 7 + INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/) + + INTEGER :: encoding + INTEGER :: error + LOGICAL :: Lexists + INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: extend_dim = (/TEST6_DIM1-2,TEST6_DIM2-3/) + INTEGER(HSIZE_T), DIMENSION(1:2) :: dimsout, maxdimsout ! dimensions + + INTEGER :: i + INTEGER :: tmp1, tmp2 + INTEGER(HID_T) :: crp_list + +! WRITE(*,*) "link creation property lists (w/new group format)" + + + ! Actually, intermediate group creation is tested elsewhere (tmisc). + ! * Here we only need to test the character encoding property + + ! Create file + ! h5_fixname(FILENAME[0], fapl, filename, sizeof filename); + + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) + CALL check("H5Fcreate_f", error, total_error) + + + ! Create and link a group with the default LCPL + + CALL H5Gcreate_f(file_id, "/group", group_id, error) + CALL check("H5Gcreate_f", error, total_error) + + + ! Check that its character encoding is the default + + CALL H5Lget_info_f(file_id, "group", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error, H5P_DEFAULT_F) + +! File-wide default character encoding can not yet be set via the file +! * creation property list and is always ASCII. +!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- + + CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) + + ! Create and commit a datatype with the default LCPL + CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) + CALL check("h5tcopy_f",error,total_error) + CALL h5tcommit_f(file_id, "/type", type_id, error) + CALL check("h5tcommit_f", error, total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f", error, total_error) + + + ! Check that its character encoding is the default + CALL H5Lget_info_f(file_id, "type", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("h5tclose_f", error, total_error) + +! File-wide default character encoding can not yet be set via the file +! * creation property list and is always ASCII. +!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- + + CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) + + ! Create a dataspace + CALL h5screate_simple_f(2, dims, space_id, error) + CALL check("h5screate_simple_f",error,total_error) + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) + CALL h5pset_chunk_f(crp_list, 2, dims, error) + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) + CALL h5pset_chunk_f(crp_list, 2, dims, error) + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) + CALL h5pset_chunk_f(crp_list, 2, dims, error) + + ! Create a dataset using the default LCPL + CALL h5dcreate_f(file_id, "/dataset", H5T_NATIVE_INTEGER, space_id, dset_id, error, crp_list) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + ! Reopen + + CALL H5Dopen_f(file_id, "/dataset", dset_id, error) + CALL check("h5dopen_f", error, total_error) + + ! Extend the dataset + CALL H5Dset_extent_f(dset_id, extend_dim, error) + CALL check("H5Dset_extent_f", error, total_error) + ! Verify the dataspaces + ! + !Get dataset's dataspace handle. + ! + CALL h5dget_space_f(dset_id, data_space, error) + CALL check("h5dget_space_f",error,total_error) + + CALL h5sget_simple_extent_dims_f(data_space, dimsout, maxdimsout, error) + CALL check("h5sget_simple_extent_dims_f",error, total_error) + + DO i = 1, 2 + tmp1 = INT(dimsout(i)) + tmp2 = INT(extend_dim(i)) + CALL verify("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) + tmp1 = INT(maxdimsout(i)) + tmp2 = INT(dims(i)) + CALL verify("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) + ENDDO + + ! close data set + + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + ! Check that its character encoding is the default + CALL H5Lget_info_f(file_id, "dataset", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + +! File-wide default character encoding can not yet be set via the file +! * creation property list and is always ASCII. +!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- + + CALL verify("h5tclose_f",cset, H5T_CSET_ASCII_F,total_error) + + ! Create a link creation property list with the UTF-8 character encoding + CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) + CALL check("h5Pcreate_f",error,total_error) + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + + ! Create and link a group with the new LCPL + CALL H5Gcreate_f(file_id, "/group2", group_id, error,lcpl_id=lcpl_id) + CALL check("H5Gcreate_f", error, total_error) + CALL H5Gclose_f(group_id, error) + CALL check("H5Gclose_f", error, total_error) + + + ! Check that its character encoding is UTF-8 + CALL H5Lget_info_f(file_id, "group2", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! Create and commit a datatype with the new LCPL + + CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) + CALL check("h5tcopy_f",error,total_error) + CALL h5tcommit_f(file_id, "/type2", type_id, error, lcpl_id=lcpl_id) + CALL check("h5tcommit_f", error, total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f", error, total_error) + + + ! Check that its character encoding is UTF-8 + CALL H5Lget_info_f(file_id, "type2", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + ! Create a dataset using the new LCPL + CALL h5dcreate_f(file_id, "/dataset2", H5T_NATIVE_INTEGER, space_id, dset_id, error,lcpl_id=lcpl_id) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL H5Pget_char_encoding_f(lcpl_id, encoding, error) + CALL check("H5Pget_char_encoding_f", error, total_error) + CALL verify("H5Pget_char_encoding_f", encoding, H5T_CSET_UTF8_F, total_error) + + ! Check that its character encoding is UTF-8 + CALL H5Lget_info_f(file_id, "dataset2", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f2",cset, H5T_CSET_UTF8_F,total_error) + + ! Create a new link to the dataset with a different character encoding. + CALL H5Pclose_f(lcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + + CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) + CALL check("h5Pcreate_f",error,total_error) + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + CALL H5Lcreate_hard_f(file_id, "/dataset2", file_id, "/dataset2_link", error, lcpl_id) + CALL check("H5Lcreate_hard_f",error, total_error) + + CALL H5Lexists_f(file_id,"/dataset2_link",Lexists, error) + CALL check("H5Lexists",error, total_error) + CALL verify("H5Lexists", Lexists,.TRUE.,total_error) + + ! Check that its character encoding is ASCII + CALL H5Lget_info_f(file_id, "/dataset2_link", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) + + ! Check that the first link's encoding hasn't changed + + CALL H5Lget_info_f(file_id, "/dataset2", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f3",cset, H5T_CSET_UTF8_F,total_error) + + + ! Make sure that LCPLs work properly for other API calls: + ! H5Lcreate_soft + + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + CALL H5Lcreate_soft_f("dataset2", file_id, "slink_to_dset2",error,lcpl_id) + CALL check("H5Lcreate_soft_f", error, total_error) + + CALL H5Lget_info_f(file_id, "slink_to_dset2", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! H5Lmove + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + + CALL H5Lmove_f(file_id, "slink_to_dset2", file_id, "moved_slink", error, lcpl_id, H5P_DEFAULT_F) + CALL check("H5Lmove_f",error, total_error) + + CALL H5Lget_info_f(file_id, "moved_slink", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) + + + ! H5Lcopy + + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) + CALL check("H5Pset_char_encoding_f",error, total_error) + + CALL H5Lcopy_f(file_id, "moved_slink", file_id, "copied_slink", error, lcpl_id) + + CALL H5Lget_info_f(file_id, "copied_slink", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! H5Lcreate_external + + CALL H5Lcreate_external_f("filename", "path", file_id, "extlink", error, lcpl_id) + CALL check("H5Lcreate_external_f", error, total_error) + + CALL H5Lget_info_f(file_id, "extlink", & + cset, corder, f_corder_valid, link_type, address, val_size, & + error) + CALL check("H5Lget_info_f", error, total_error) + CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! Close open IDs + + CALL H5Pclose_f(lcpl_id, error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Sclose_f(space_id, error) + CALL check("h5Sclose_f",error,total_error) + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f("tempfile", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + +END SUBROUTINE test_lcpl + +SUBROUTINE objcopy(fapl, total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T), INTENT(IN) :: fapl + + INTEGER(HID_T) :: fapl2, pid + + INTEGER :: flag, cpy_flags + + INTEGER :: error + + flag = H5O_COPY_SHALLOW_HIERARCHY_F + +! Copy the file access property list + CALL H5Pcopy_f(fapl, fapl2, error) + CALL check("H5Pcopy_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(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) + + ! create property to pass copy options + CALL h5pcreate_f(H5P_OBJECT_COPY_F, pid, error) + CALL check("h5pcreate_f",error, total_error) + + ! set options for object copy + CALL H5Pset_copy_object_f(pid, flag, error) + CALL check("H5Pset_copy_object_f",error, total_error) + + ! Verify object copy flags + CALL H5Pget_copy_object_f(pid, cpy_flags, error) + CALL check("H5Pget_copy_object_f",error, total_error) + CALL verify("H5Pget_copy_object_f", cpy_flags, flag, total_error) + +!!$ +!!$ CALL test_copy_option(fcpl_src, fcpl_dst, my_fapl, H5O_COPY_WITHOUT_ATTR_FLAG, +!!$ FALSE, "H5Ocopy(): without attributes"); + + CALL lapl_nlinks(fapl2, total_error) + +END SUBROUTINE objcopy + + +!------------------------------------------------------------------------- +! * Function: lapl_nlinks +! * +! * Purpose: Check that the maximum number of soft links can be adjusted +! * by the user using the Link Access Property List. +! * +! * Return: Success: 0 +! * +! * Failure: -1 +! * +! * Programmer: James Laird +! * Tuesday, June 6, 2006 +! * +! * Modifications: +! * +! *------------------------------------------------------------------------- +! + +SUBROUTINE lapl_nlinks( fapl, total_error) + + IMPLICIT NONE + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(INOUT) :: total_error + + INTEGER :: error + + INTEGER(HID_T) :: fid = (-1) ! File ID + INTEGER(HID_T) :: gid = (-1), gid2 = (-1) ! Group IDs + INTEGER(HID_T) :: plist = (-1) ! lapl ID + INTEGER(HID_T) :: tid = (-1) ! Other IDs + INTEGER(HID_T) :: gapl = (-1), dapl = (-1), tapl = (-1) ! Other property lists + + CHARACTER(LEN=7) :: objname ! Object name + INTEGER(size_t) :: name_len ! Length of object name + CHARACTER(LEN=12) :: filename = 'TestLinks.h5' + INTEGER(size_t) :: nlinks ! nlinks for H5Pset_nlinks + INTEGER(size_t) :: buf_size = 7 + +! WRITE(*,*) "adjusting nlinks with LAPL (w/new group format)" + + + ! Create file + CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl) + CALL check(" lapl_nlinks.h5fcreate_f",error,total_error) + + ! Create group with short name in file (used as target for links) + CALL H5Gcreate_f(fid, "final", gid, error) + CALL check(" lapl_nlinks.H5Gcreate_f", error, total_error) + + ! Create chain of soft links to existing object (limited) + CALL H5Lcreate_soft_f("final", fid, "soft1", error) + CALL H5Lcreate_soft_f("soft1", fid, "soft2", error) + CALL H5Lcreate_soft_f("soft2", fid, "soft3", error) + CALL H5Lcreate_soft_f("soft3", fid, "soft4", error) + CALL H5Lcreate_soft_f("soft4", fid, "soft5", error) + CALL H5Lcreate_soft_f("soft5", fid, "soft6", error) + CALL H5Lcreate_soft_f("soft6", fid, "soft7", error) + CALL H5Lcreate_soft_f("soft7", fid, "soft8", error) + CALL H5Lcreate_soft_f("soft8", fid, "soft9", error) + CALL H5Lcreate_soft_f("soft9", fid, "soft10", error) + CALL H5Lcreate_soft_f("soft10", fid, "soft11", error) + CALL H5Lcreate_soft_f("soft11", fid, "soft12", error) + CALL H5Lcreate_soft_f("soft12", fid, "soft13", error) + CALL H5Lcreate_soft_f("soft13", fid, "soft14", error) + CALL H5Lcreate_soft_f("soft14", fid, "soft15", error) + CALL H5Lcreate_soft_f("soft15", fid, "soft16", error) + CALL H5Lcreate_soft_f("soft16", fid, "soft17", error) + + ! Close objects + CALL H5Gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Open file + + CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) + CALL check("h5open_f",error,total_error) + + ! Create LAPL with higher-than-usual nlinks value + ! Create a non-default lapl with udata set to point to the first group + + CALL H5Pcreate_f(H5P_LINK_ACCESS_F,plist,error) + CALL check("h5Pcreate_f",error,total_error) + nlinks = 20 + CALL H5Pset_nlinks_f(plist, nlinks, error) + CALL check("H5Pset_nlinks_f",error,total_error) + ! Ensure that nlinks was set successfully + nlinks = 0 + CALL H5Pget_nlinks_f(plist, nlinks, error) + CALL check("H5Pset_nlinks_f",error,total_error) + CALL verify("H5Pset_nlinks_f",INT(nlinks), 20, total_error) + + + ! Open object through what is normally too many soft links using + ! * new property list + + CALL H5Oopen_f(fid,"soft17",gid,error,plist) + CALL check("H5Oopen_f",error,total_error) + + ! Check name + CALL h5iget_name_f(gid, objname, buf_size, name_len, error) + CALL check("h5iget_name_f",error,total_error) + CALL verify("h5iget_name_f", TRIM(objname),"/soft17", total_error) + ! Create group using soft link + CALL H5Gcreate_f(gid, "new_soft", gid2, error) + CALL check("H5Gcreate_f", error, total_error) + + ! Close groups + CALL H5Gclose_f(gid2, error) + CALL check("H5Gclose_f", error, total_error) + CALL H5Gclose_f(gid, error) + CALL check("H5Gclose_f", error, total_error) + + + ! Set nlinks to a smaller number + nlinks = 4 + CALL H5Pset_nlinks_f(plist, nlinks, error) + CALL check("H5Pset_nlinks_f", error, total_error) + + ! Ensure that nlinks was set successfully + nlinks = 0 + + CALL H5Pget_nlinks_f(plist, nlinks, error) + CALL check("H5Pget_nlinks_f",error,total_error) + CALL verify("H5Pget_nlinks_f", INT(nlinks), 4, total_error) + + ! Try opening through what is now too many soft links + + CALL H5Oopen_f(fid,"soft5",gid,error,plist) + CALL verify("H5Oopen_f", error, -1, total_error) ! should fail + + ! Open object through lesser soft link + CALL H5Oopen_f(fid,"soft4",gid,error,plist) + CALL check("H5Oopen_",error,total_error) + + ! Check name + CALL h5iget_name_f(gid, objname, buf_size, name_len, error) + CALL check("h5iget_name_f",error,total_error) + CALL verify("h5iget_name_f", TRIM(objname),"/soft4", total_error) + + ! Test other functions that should use a LAPL + nlinks = 20 + CALL H5Pset_nlinks_f(plist, nlinks, error) + CALL check("H5Pset_nlinks_f", error, total_error) + + ! Try copying and moving when both src and dst contain many soft links + ! * using a non-default LAPL + ! + CALL H5Lcopy_f(fid, "soft17", fid, "soft17/newer_soft", error, H5P_DEFAULT_F, plist) + CALL check("H5Lcopy_f",error,total_error) + + CALL H5Lmove_f(fid, "soft17/newer_soft", fid, "soft17/newest_soft", error, lapl_id=plist) + CALL check("H5Lmove_f",error, total_error) + + ! H5Olink + CALL H5Olink_f(gid, fid, "soft17/link_to_group", error, H5P_DEFAULT_F, plist) + CALL check("H5Olink_f", error, total_error) + + ! H5Lcreate_hard and H5Lcreate_soft + CALL H5Lcreate_hard_f(fid, "soft17", fid, "soft17/link2_to_group", error, H5P_DEFAULT_F, plist) + CALL check("H5Lcreate_hard_f", error, total_error) + + + CALL H5Lcreate_soft_f("/soft4", fid, "soft17/soft_link",error, H5P_DEFAULT_F, plist) + CALL check("H5Lcreate_soft_f", error, total_error) + + ! H5Ldelete + CALL h5ldelete_f(fid, "soft17/soft_link", error, plist) + CALL check("H5Ldelete_f", error, total_error) + +!!$ H5Lget_val and H5Lget_info +!!$ if(H5Lget_val(fid, "soft17", NULL, (size_t)0, plist) < 0) TEST_ERROR +!!$ if(H5Lget_info(fid, "soft17", NULL, plist) < 0) TEST_ERROR +!!$ + + ! H5Lcreate_external and H5Lcreate_ud + CALL H5Lcreate_external_f("filename", "path", fid, "soft17/extlink", error, H5P_DEFAULT_F, plist) + CALL check("H5Lcreate_external_f", error, total_error) + +!!$ if(H5Lregister(UD_rereg_class) < 0) TEST_ERROR +!!$ if(H5Lcreate_ud(fid, "soft17/udlink", UD_HARD_TYPE, NULL, (size_t)0, H5P_DEFAULT, plist) < 0) TEST_ERROR +!!$ + ! Close plist + CALL h5pclose_f(plist, error) + CALL check("h5pclose_f", error, total_error) + + ! Create a datatype and dataset as targets inside the group + CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error) + CALL check("h5tcopy_f",error,total_error) + CALL h5tcommit_f(gid, "datatype", tid, error) + CALL check("h5tcommit_f", error, total_error) + CALL h5tclose_f(tid, error) + CALL check("h5tclose_f", error, total_error) + +!!$ +!!$ dims[0] = 2; +!!$ dims[1] = 2; +!!$ if((sid = H5Screate_simple(2, dims, NULL)) < 0) TEST_ERROR +!!$ if((did = H5Dcreate2(gid, "dataset", H5T_NATIVE_INT, sid, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR +!!$ if(H5Dclose(did) < 0) TEST_ERROR +!!$ + ! Close group + CALL h5gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + +!!$ +!!$ Try to open the objects using too many symlinks with default *APLs +!!$ H5E_BEGIN_TRY { +!!$ if((gid = H5Gopen2(fid, "soft17", H5P_DEFAULT)) >= 0) +!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") +!!$ if((tid = H5Topen2(fid, "soft17/datatype", H5P_DEFAULT)) >= 0) +!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") +!!$ if((did = H5Dopen2(fid, "soft17/dataset", H5P_DEFAULT)) >= 0) +!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") +!!$ } H5E_END_TRY +!!$ + ! Create property lists with nlinks set + + CALL H5Pcreate_f(H5P_GROUP_ACCESS_F,gapl,error) + CALL check("h5Pcreate_f",error,total_error) + CALL H5Pcreate_f(H5P_DATATYPE_ACCESS_F,tapl,error) + CALL check("h5Pcreate_f",error,total_error) + CALL H5Pcreate_f(H5P_DATASET_ACCESS_F,dapl,error) + CALL check("h5Pcreate_f",error,total_error) + + + nlinks = 20 + CALL H5Pset_nlinks_f(gapl, nlinks, error) + CALL check("H5Pset_nlinks_f", error, total_error) + CALL H5Pset_nlinks_f(tapl, nlinks, error) + CALL check("H5Pset_nlinks_f", error, total_error) + CALL H5Pset_nlinks_f(dapl, nlinks, error) + CALL check("H5Pset_nlinks_f", error, total_error) + + ! We should now be able to use these property lists to open each kind + ! * of object. + ! + + CALL H5Gopen_f(fid, "soft17", gid, error, gapl) + CALL check("H5Gopen_f",error,total_error) + + CALL H5Topen_f(fid, "soft17/datatype", tid, error, tapl) + CALL check("H5Gopen_f",error,total_error) + +!!$ if((did = H5Dopen2(fid, "soft17/dataset", dapl)) < 0) TEST_ERROR + + ! Close objects + + CALL h5gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + CALL h5tclose_f(tid, error) + CALL check("h5tclose_f", error, total_error) + +!!$ if(H5Dclose(did) < 0) TEST_ERROR +!!$ + ! Close plists + + CALL h5pclose_f(gapl, error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(tapl, error) + CALL check("h5pclose_f", error, total_error) + +!!$ if(H5Pclose(dapl) < 0) TEST_ERROR +!!$ +!!$ Unregister UD hard link class +!!$ if(H5Lunregister(UD_HARD_TYPE) < 0) TEST_ERROR +!!$ + + ! Close file + CALL H5Fclose_f(fid, error) + CALL check("H5Fclose_f", error, total_error) + +END SUBROUTINE lapl_nlinks + +END MODULE TH5G_1_8 diff --git a/fortran/test/tH5G_1_8.f90 b/fortran/test/tH5G_1_8.f90 deleted file mode 100644 index ddc3736..0000000 --- a/fortran/test/tH5G_1_8.f90 +++ /dev/null @@ -1,2126 +0,0 @@ -!****h* root/fortran/test/tH5G_1_8.f90 -! -! NAME -! tH5G_1_8.f90 -! -! FUNCTION -! Basic testing of Fortran H5G APIs introduced in 1.8. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! group_test, group_info, timestamps, mklinks, test_move_preserves, lifecycle -! cklinks, delete_by_idx, link_info_by_idx_check, test_lcpl, objcopy, -! lapl_nlinks -! -!***** - -MODULE TH5G_1_8 - - USE HDF5 - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -SUBROUTINE group_test(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(HID_T) :: fapl, fapl2, my_fapl ! File access property lists - - INTEGER :: error, ret_total_error - -! WRITE(*,*) "TESTING GROUPS" - CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error) - CALL check("H5Pcreate_f",error, total_error) - - ! Copy the file access property list - CALL H5Pcopy_f(fapl, fapl2, error) - CALL check("H5Pcopy_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(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) - CALL check("H5Pset_libver_bounds_f",error, total_error) - - ! Check for FAPL to USE - my_fapl = fapl2 - - ret_total_error = 0 - CALL mklinks(fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing building a file with assorted links', & - total_error) - - ret_total_error = 0 - CALL cklinks(fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing links are correct and building assorted links', & - total_error) - - ret_total_error = 0 - CALL group_info(cleanup, fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing create group with creation order indices, test querying group info', & - total_error) - -! CALL ud_hard_links(fapl2,total_error) - ret_total_error = 0 - CALL timestamps(cleanup, fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing disabling tracking timestamps for an object', & - total_error) - - ret_total_error = 0 - CALL test_move_preserves(fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing moving and renaming links preserves their properties', & - total_error) - - ret_total_error = 0 - CALL delete_by_idx(cleanup,fapl2,ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing deleting links by index', & - total_error) - - ret_total_error = 0 - CALL test_lcpl(cleanup, fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing link creation property lists', & - total_error) - - ret_total_error = 0 - CALL objcopy(fapl, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing object copy', & - total_error) - - ret_total_error = 0 - CALL lifecycle(cleanup, fapl2, ret_total_error) - CALL write_test_status(ret_total_error, & - ' Testing adding links to a group follow proper "lifecycle"', & - total_error) - - IF(cleanup) CALL h5_cleanup_f("TestLinks", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - -END SUBROUTINE group_test - -!------------------------------------------------------------------------- -! * Function: group_info -! * -! * Purpose: Create a group with creation order indices and test querying -! * group info. -! * -! * Return: Success: 0 -! * Failure: -1 -! * -! * Programmer: Adapted from C test routines by -! * M.S. Breitenfeld -! * February 18, 2008 -! * -! *------------------------------------------------------------------------- -! - -SUBROUTINE group_info(cleanup, fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - - INTEGER(HID_T) :: gcpl_id ! Group creation property list ID - - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - INTEGER :: idx_type ! Type of index to operate on - INTEGER :: order, iorder ! Order within in the index - LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) ! Use index on creation order values - CHARACTER(LEN=6), PARAMETER :: prefix = 'links0' - CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name - INTEGER :: Input1 - INTEGER(HID_T) :: group_id ! Group ID - INTEGER(HID_T) :: soft_group_id ! Group ID for soft links - - INTEGER :: i ! Local index variables - INTEGER :: storage_type ! Type of storage for links in group: - ! H5G_STORAGE_TYPE_COMPACT: Compact storage - ! H5G_STORAGE_TYPE_DENSE: Indexed storage - ! H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure - INTEGER :: nlinks ! Number of links in group - INTEGER :: max_corder ! Current maximum creation order value for group - - INTEGER :: u,v ! Local index variables - CHARACTER(LEN=2) :: chr2 - INTEGER(HID_T) :: group_id2, group_id3 ! Group IDs - CHARACTER(LEN=7) :: objname ! Object name - CHARACTER(LEN=7) :: objname2 ! Object name - CHARACTER(LEN=19) :: valname ! Link value - CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" - CHARACTER(LEN=17), PARAMETER :: CORDER_SOFT_GROUP_NAME = "corder_soft_group" - INTEGER(HID_T) :: file_id ! File ID - INTEGER :: error ! Generic return value - LOGICAL :: mounted - LOGICAL :: cleanup - - ! Create group creation property list - CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) - CALL check("H5Pcreate_f", error, total_error) - - ! Query the group creation properties - CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) - CALL check("H5Pget_link_phase_change_f", error, total_error) - - ! Loop over operating on different indices on link fields - DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F - ! Loop over operating in different orders - DO iorder = H5_ITER_INC_F, H5_ITER_NATIVE_F - ! Loop over using index for creation order value - DO i = 1, 2 - ! Print appropriate test message - IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN - IF(iorder == H5_ITER_INC_F)THEN - order = H5_ITER_INC_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" -!!$ ENDIF - ELSE IF (iorder == H5_ITER_DEC_F) THEN - order = H5_ITER_DEC_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" -!!$ ENDIF - ELSE - order = H5_ITER_NATIVE_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" -!!$ ENDIF - ENDIF - ELSE - IF(iorder == H5_ITER_INC_F)THEN - order = H5_ITER_INC_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" -!!$ ENDIF - ELSE IF (iorder == H5_ITER_DEC_F) THEN - order = H5_ITER_DEC_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" -!!$ ENDIF - ELSE - order = H5_ITER_NATIVE_F -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" -!!$ ENDIF - ENDIF - END IF - - ! Create file - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) - CALL check("H5Fcreate_f", error, total_error) - - ! Set creation order tracking & indexing on group - IF(use_index(i))THEN - Input1 = H5P_CRT_ORDER_INDEXED_F - ELSE - Input1 = 0 - ENDIF - CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) - CALL check("H5Pset_link_creation_order_f", error, total_error) - - ! Create group with creation order tracking on - CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) - CALL check("H5Gcreate_f", error, total_error) - - ! Create group with creation order tracking on for soft links - CALL H5Gcreate_f(file_id, CORDER_SOFT_GROUP_NAME, soft_group_id, error, & - OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) - CALL check("H5Gcreate_f", error, total_error) - - ! Check for out of bound query by index on empty group, should fail - CALL H5Gget_info_by_idx_f(group_id, ".", H5_INDEX_NAME_F, order, INT(0,HSIZE_T), & - storage_type, nlinks, max_corder, error) - CALL verify("H5Gget_info_by_idx_f", error, -1, total_error) - - ! Create several links, up to limit of compact form - DO u = 0, max_compact-1 - - ! Make name for link - WRITE(chr2,'(I2.2)') u - objname = 'fill '//chr2 - - ! Create hard link, with group object - CALL H5Gcreate_f(group_id, objname, group_id2, error, OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) - CALL check("H5Gcreate_f", error, total_error) - - ! Retrieve group's information - CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error, mounted) - CALL check("H5Gget_info_f", error, total_error) - - ! Check (new/empty) group's information - CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_f", max_corder, 0, total_error) - CALL verify("H5Gget_info_f", nlinks, 0, total_error) - CALL verify("H5Gget_info_f.mounted", mounted,.FALSE.,total_error) - - ! Retrieve group's information - CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error, mounted=mounted) - CALL check("H5Gget_info_by_name_f", error, total_error) - - ! Check (new/empty) group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f", max_corder, 0, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, 0, total_error) - CALL verify("H5Gget_info_by_name_f.mounted", mounted,.FALSE.,total_error) - - ! Retrieve group's information - CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_by_name", error, total_error) - - ! Check (new/empty) group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f", max_corder, 0, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, 0, total_error) - - ! Create objects in new group created - DO v = 0, u - ! Make name for link - WRITE(chr2,'(I2.2)') v - objname2 = 'fill '//chr2 - - ! Create hard link, with group object - CALL H5Gcreate_f(group_id2, objname2, group_id3, error ) - CALL check("H5Gcreate_f", error, total_error) - - ! Close group created - CALL H5Gclose_f(group_id3, error) - CALL check("H5Gclose_f", error, total_error) - ENDDO - - ! Retrieve group's information - CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_f", error, total_error) - - ! Check (new) group's information - CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_f", nlinks, u+1, total_error) - - ! Retrieve group's information - CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_by_name_f", error, total_error) - - ! Check (new) group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f",max_corder, u+1, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) - - ! Retrieve group's information - CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_by_name_f", error, total_error) - - ! Check (new) group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) - - ! Retrieve group's information - IF(order.NE.H5_ITER_NATIVE_F)THEN - IF(order.EQ.H5_ITER_INC_F) THEN - CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(u,HSIZE_T), & - storage_type, nlinks, max_corder, error,lapl_id=H5P_DEFAULT_F, mounted=mounted) - CALL check("H5Gget_info_by_idx_f", error, total_error) - CALL verify("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) - ELSE - CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), & - storage_type, nlinks, max_corder, error, mounted=mounted) - CALL verify("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) - CALL check("H5Gget_info_by_idx_f", error, total_error) - ENDIF - ! Check (new) group's information - CALL verify("H5Gget_info_by_idx_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_idx_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_by_idx_f", nlinks, u+1, total_error) - ENDIF - ! Close group created - CALL H5Gclose_f(group_id2, error) - CALL check("H5Gclose_f", error, total_error) - - ! Retrieve main group's information - CALL H5Gget_info_f(group_id, storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_f", error, total_error) - - ! Check main group's information - CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_f", nlinks, u+1, total_error) - - ! Retrieve main group's information, by name - CALL H5Gget_info_by_name_f(file_id, CORDER_GROUP_NAME, storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_by_name_f", error, total_error) - - ! Check main group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) - - ! Retrieve main group's information, by name - CALL H5Gget_info_by_name_f(group_id, ".", storage_type, nlinks, max_corder, error, H5P_DEFAULT_F) - CALL check("H5Gget_info_by_name_f", error, total_error) - - ! Check main group's information - CALL verify("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_by_name_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_by_name_f", nlinks, u+1, total_error) - - ! Create soft link in another group, to objects in main group - valname = CORDER_GROUP_NAME//objname - - CALL H5Lcreate_soft_f(valname, soft_group_id, objname, error, H5P_DEFAULT_F, H5P_DEFAULT_F) - - ! Retrieve soft link group's information, by name - CALL H5Gget_info_f(soft_group_id, storage_type, nlinks, max_corder, error) - CALL check("H5Gget_info_f", error, total_error) - - ! Check soft link group's information - CALL verify("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) - CALL verify("H5Gget_info_f", max_corder, u+1, total_error) - CALL verify("H5Gget_info_f", nlinks, u+1, total_error) - ENDDO - - ! Close the groups - - CALL H5Gclose_f(group_id, error) - CALL check("H5Gclose_f", error, total_error) - CALL H5Gclose_f(soft_group_id, error) - CALL check("H5Gclose_f", error, total_error) - - ! Close the file - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - ENDDO - ENDDO - ENDDO - - ! Free resources - CALL H5Pclose_f(gcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - - END SUBROUTINE group_info - -!------------------------------------------------------------------------- -! * Function: timestamps -! * -! * Purpose: Verify that disabling tracking timestamps for an object -! * works correctly -! * -! * -! * Programmer: M.S. Breitenfeld -! * February 20, 2008 -! * -! *------------------------------------------------------------------------- -! - - SUBROUTINE timestamps(cleanup, fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - - INTEGER(HID_T) :: file_id ! File ID - INTEGER(HID_T) :: group_id ! Group ID - INTEGER(HID_T) :: group_id2 ! Group ID - INTEGER(HID_T) :: gcpl_id ! Group creation property list ID - INTEGER(HID_T) :: gcpl_id2 ! Group creation property list ID - - CHARACTER(LEN=6), PARAMETER :: prefix = 'links9' - CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name - ! Timestamp macros - CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_1="timestamp1" - CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_2="timestamp2" - LOGICAL :: track_times - LOGICAL :: cleanup - - INTEGER :: error - - ! Print test message -! WRITE(*,*) "timestamps on objects" - - ! Create group creation property list - CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) - CALL check("H5Pcreate_f", error, total_error) - - ! Query the object timestamp setting - CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - - ! Check default timestamp information - CALL verify("H5Pget_obj_track_times",track_times,.TRUE.,total_error) - - ! Set a non-default object timestamp setting - CALL H5Pset_obj_track_times_f(gcpl_id, .FALSE., error) - CALL check("H5Pset_obj_track_times_f", error, total_error) - - ! Query the object timestamp setting - CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - - ! Check default timestamp information - CALL verify("H5Pget_obj_track_times",track_times,.FALSE.,total_error) - - ! Create file - !h5_fixname(FILENAME[0], fapl, filename, sizeof filename); - - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) - CALL check("h5fcreate_f",error,total_error) - - ! Create group with non-default object timestamp setting - CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_1, group_id, error, & - OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id, H5P_DEFAULT_F) - CALL check("h5fcreate_f",error,total_error) - - ! Close the group creation property list - CALL H5Pclose_f(gcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - - ! Create group with default object timestamp setting - CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, & - OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("h5fcreate_f",error,total_error) - - ! Retrieve the new groups' creation properties - CALL H5Gget_create_plist_f(group_id, gcpl_id, error) - CALL check("H5Gget_create_plist", error, total_error) - CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) - CALL check("H5Gget_create_plist", error, total_error) - - ! Query & verify the object timestamp settings - CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - CALL verify("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) - CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - CALL verify("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) - -! Query the object information for each group -! if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR -! if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR - -!!$ Sanity check object information for each group -!!$ if(oinfo.atime != 0) TEST_ERROR -!!$ if(oinfo.mtime != 0) TEST_ERROR -!!$ if(oinfo.ctime != 0) TEST_ERROR -!!$ if(oinfo.btime != 0) TEST_ERROR -!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR -!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR -!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR -!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR -!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR -!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR -!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR -!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR - - ! Close the property lists - CALL H5Pclose_f(gcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(gcpl_id2, error) - CALL check("H5Pclose_f", error, total_error) - - ! Close the groups - CALL H5Gclose_f(group_id, error) - CALL check("H5Gclose_f", error, total_error) - CALL H5Gclose_f(group_id2, error) - CALL check("H5Gclose_f", error, total_error) - - ! Close the file - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - - ! Re-open the file - - CALL h5fopen_f(FileName, H5F_ACC_RDONLY_F, file_id, error, H5P_DEFAULT_F) - CALL check("h5fopen_f",error,total_error) - - ! Open groups - CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_1, group_id, error) ! with no optional param. - CALL check("H5Gopen_f", error, total_error) - CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, H5P_DEFAULT_F) ! with optional param. - CALL check("H5Gopen_f", error, total_error) - - ! Retrieve the new groups' creation properties - CALL H5Gget_create_plist_f(group_id, gcpl_id, error) - CALL check("H5Gget_create_plist", error, total_error) - CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) - CALL check("H5Gget_create_plist", error, total_error) - - ! Query & verify the object timestamp settings - - CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - CALL verify("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) - CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) - CALL check("H5Pget_obj_track_times_f", error, total_error) - CALL verify("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) -!!$ -!!$ Query the object information for each group -!!$ if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR -!!$ if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR -!!$ -!!$ Sanity check object information for each group -!!$ if(oinfo.atime != 0) TEST_ERROR -!!$ if(oinfo.mtime != 0) TEST_ERROR -!!$ if(oinfo.ctime != 0) TEST_ERROR -!!$ if(oinfo.btime != 0) TEST_ERROR -!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR -!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR -!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR -!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR -!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR -!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR -!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR -!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR - - ! Close the property lists - CALL H5Pclose_f(gcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(gcpl_id2, error) - CALL check("H5Pclose_f", error, total_error) - - ! Close the groups - CALL H5Gclose_f(group_id, error) - CALL check("H5Gclose_f", error, total_error) - CALL H5Gclose_f(group_id2, error) - CALL check("H5Gclose_f", error, total_error) - - ! Close the file - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - END SUBROUTINE timestamps - -!------------------------------------------------------------------------- -! * Function: mklinks -! * -! * Purpose: Build a file with assorted links. -! * -! * -! * Programmer: Adapted from C test by: -! * M.S. Breitenfeld -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - - SUBROUTINE mklinks(fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - - INTEGER(HID_T) :: file, scalar, grp, d1 - CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' - INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension - INTEGER :: arank = 1 ! Attribure rank - INTEGER :: error - - INTEGER :: cset ! Indicates the character set used for the link’s name. - INTEGER :: corder ! Specifies the link’s creation order position. - LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. - INTEGER :: link_type ! Specifies the link class: - ! H5L_TYPE_HARD_F - Hard link - ! H5L_TYPE_SOFT_F - Soft link - ! H5L_TYPE_EXTERNAL_F - External link - ! H5L_TYPE_ERROR _F - Error - INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to - INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value - - -! WRITE(*,*) "link creation (w/new group format)" - - ! Create a file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl) - CALL check("mklinks.h5fcreate_f",error,total_error) - CALL h5screate_simple_f(arank, adims2, scalar, error) - CALL check("mklinks.h5screate_simple_f",error,total_error) - - ! Create a group - CALL H5Gcreate_f(file, "grp1", grp, error) - CALL check("H5Gcreate_f", error, total_error) - CALL H5Gclose_f(grp, error) - CALL check("h5gclose_f",error,total_error) - - ! Create a dataset - CALL h5dcreate_f(file, "d1", H5T_NATIVE_INTEGER, scalar, d1, error) - CALL check("h5dcreate_f",error,total_error) - CALL h5dclose_f(d1, error) - CALL check("h5dclose_f",error,total_error) - - ! Create a hard link - CALL H5Lcreate_hard_f(file, "d1", INT(H5L_SAME_LOC_F,HID_T), "grp1/hard", error) - CALL check("H5Lcreate_hard_f", error, total_error) - - ! Create a symbolic link - CALL H5Lcreate_soft_f("/d1", file, "grp1/soft",error) - CALL check("H5Lcreate_soft_f", error, total_error) - - CALL H5Lget_info_f(file, "grp1/soft", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error, H5P_DEFAULT_F) - CALL check("H5Lget_info_f",error,total_error) - -! CALL verify("H5Lget_info_by_idx_f11", f_corder_valid, .TRUE., total_error) - - CALL verify("H5Lget_info_by_idx_f", H5L_TYPE_SOFT_F, link_type, total_error) - CALL verify("H5Lget_info_by_idx_f", cset, H5T_CSET_ASCII_F, total_error) - ! should be '/d1' + NULL character = 4 - CALL verify("H5Lget_info_by_idx_f", INT(val_size), 4, total_error) - - ! Create a symbolic link to something that doesn't exist - - CALL H5Lcreate_soft_f("foobar", file, "grp1/dangle",error) - - ! Create a recursive symbolic link - CALL H5Lcreate_soft_f("/grp1/recursive", file, "/grp1/recursive",error) - - ! Close - CALL h5sclose_f(scalar, error) - CALL check("h5sclose_f",error,total_error) - CALL h5fclose_f(file, error) - CALL check("h5fclose_f",error,total_error) - - END SUBROUTINE mklinks - -!------------------------------------------------------------------------- -! * Function: test_move_preserves -! * -! * Purpose: Tests that moving and renaming links preserves their -! * properties. -! * -! * Programmer: M.S. Breitenfeld -! * March 3, 2008 -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - - SUBROUTINE test_move_preserves(fapl_id, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl_id - - INTEGER(HID_T):: file_id - INTEGER(HID_T):: group_id - INTEGER(HID_T):: fcpl_id ! Group creation property list ID - INTEGER(HID_T):: lcpl_id - !H5O_info_t oinfo; - !H5L_info_t linfo; - INTEGER :: old_cset - INTEGER :: old_corder - !H5T_cset_t old_cset; - !int64_t old_corder; Creation order value of link - !time_t old_modification_time; - !time_t curr_time; - !unsigned crt_order_flags; Status of creation order info for GCPL - !char filename[1024]; - - INTEGER :: crt_order_flags ! Status of creation order info for GCPL - CHARACTER(LEN=12), PARAMETER :: filename = 'TestLinks.h5' - - INTEGER :: cset ! Indicates the character set used for the link’s name. - INTEGER :: corder ! Specifies the link’s creation order position. - LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. - INTEGER :: link_type ! Specifies the link class: - ! H5L_TYPE_HARD_F - Hard link - ! H5L_TYPE_SOFT_F - Soft link - ! H5L_TYPE_EXTERNAL_F - External link - ! H5L_TYPE_ERROR _F - Error - INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to - INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value - - INTEGER :: error - -! WRITE(*,*) "moving and copying links preserves their properties (w/new group format)" - - ! Create a file creation property list with creation order stored for links - ! * in the root group - ! - - CALL H5Pcreate_f(H5P_FILE_CREATE_F, fcpl_id, error) - CALL check("H5Pcreate_f",error, total_error) - - CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) - CALL check("H5Pget_link_creation_order_f",error, total_error) - CALL verify("H5Pget_link_creation_order_f",crt_order_flags,0, total_error) - - CALL H5Pset_link_creation_order_f(fcpl_id, H5P_CRT_ORDER_TRACKED_F, error) - CALL check("H5Pset_link_creation_order_f", error, total_error) - - CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) - CALL check("H5Pget_link_creation_order_f",error, total_error) - CALL verify("H5Pget_link_creation_order_f",crt_order_flags, H5P_CRT_ORDER_TRACKED_F, total_error) - - ! Create file - ! (with creation order tracking for the root group) - - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file_id, error, fcpl_id, fapl_id) - CALL check("h5fcreate_f",error,total_error) - - ! Create a link creation property list with the UTF-8 character encoding - CALL H5Pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) - CALL check("H5Pcreate_f",error, total_error) - - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - - ! Create a group with that lcpl - CALL H5Gcreate_f(file_id, "group", group_id, error,lcpl_id=lcpl_id, gcpl_id=H5P_DEFAULT_F, gapl_id=H5P_DEFAULT_F) - CALL check("H5Gcreate_f", error, total_error) - CALL H5Gclose_f(group_id, error) - CALL check("H5Gclose_f", error, total_error) - - ! Get the group's link's information - CALL H5Lget_info_f(file_id, "group", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error, H5P_DEFAULT_F) - CALL check("H5Lget_info_f",error,total_error) - -! if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR - - old_cset = cset - CALL verify("H5Lget_info_f",old_cset,H5T_CSET_UTF8_F,total_error) - CALL verify("H5Lget_info_f",f_corder_valid,.TRUE.,total_error) - old_corder = corder; - CALL verify("H5Lget_info_f",old_corder,0,total_error) - -! old_modification_time = oinfo.mtime; - -! If this test happens too quickly, the times will all be the same. Make sure the time changes. -! curr_time = HDtime(NULL); -! while(HDtime(NULL) <= curr_time) -! ; - -! Close the file and reopen it - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - -!!$ if((file_id = H5Fopen(filename, H5F_ACC_RDWR, fapl_id)) < 0) TEST_ERROR -!!$ -!!$ Get the link's character set & modification time . They should be unchanged -!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(old_cset != linfo.cset) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(old_corder != linfo.corder) TEST_ERROR -!!$ -!!$ Create a new link to the group. It should have a different creation order value but the same modification time -!!$ if(H5Lcreate_hard(file_id, "group", file_id, "group2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_corder == linfo.corder) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(linfo.corder != 1) TEST_ERROR -!!$ if(linfo.cset != H5T_CSET_ASCII) TEST_ERROR -!!$ -!!$ Copy the first link to a UTF-8 name. -!!$ * Its creation order value should be different, but modification time -!!$ * should not change. -!!$ -!!$ if(H5Lcopy(file_id, "group", file_id, "group_copied", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group_copied", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group_copied", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(linfo.corder != 2) TEST_ERROR -!!$ -!!$ Check that its character encoding is UTF-8 -!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR -!!$ -!!$ Move the link with the default property list. -!!$ if(H5Lmove(file_id, "group_copied", file_id, "group_copied2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group_copied2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group_copied2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(linfo.corder != 3) TEST_ERROR -!!$ -!!$ Check that its character encoding is not UTF-8 -!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR -!!$ -!!$ Check that the original link is unchanged -!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(old_corder != linfo.corder) TEST_ERROR -!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR -!!$ -!!$ Move the first link to a UTF-8 name. -!!$ * Its creation order value will change, but modification time should not -!!$ * change. -!!$ if(H5Lmove(file_id, "group", file_id, "group_moved", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group_moved", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group_moved", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(linfo.corder != 4) TEST_ERROR -!!$ -!!$ Check that its character encoding is UTF-8 -!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR -!!$ -!!$ Move the link again using the default property list. -!!$ if(H5Lmove(file_id, "group_moved", file_id, "group_moved_again", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(H5Oget_info_by_name(file_id, "group_moved_again", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR -!!$ if(H5Lget_info(file_id, "group_moved_again", &linfo, H5P_DEFAULT) < 0) TEST_ERROR -!!$ if(linfo.corder_valid != TRUE) TEST_ERROR -!!$ if(linfo.corder != 5) TEST_ERROR -!!$ -!!$ Check that its character encoding is not UTF-8 -!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR - - ! Close open IDs - CALL H5Pclose_f(fcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(lcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - - ! if(H5Fclose(file_id) < 0) TEST_ERROR - - END SUBROUTINE test_move_preserves - -!------------------------------------------------------------------------- -! * Function: lifecycle -! * -! * Purpose: Test that adding links to a group follow proper "lifecycle" -! * of empty->compact->symbol table->compact->empty. (As group -! * is created, links are added, then links removed) -! * -! * Return: Success: 0 -! * -! * Failure: -1 -! * -! * Programmer: Quincey Koziol -! * Monday, October 17, 2005 -! * -! *------------------------------------------------------------------------- -! -SUBROUTINE lifecycle(cleanup, fapl2, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl2 - INTEGER :: error - - INTEGER, PARAMETER :: NAME_BUF_SIZE =7 - - INTEGER(HID_T) :: fid ! File ID - INTEGER(HID_T) :: gid ! Group ID - INTEGER(HID_T) :: gcpl ! Group creation property list ID - INTEGER(size_t) :: lheap_size_hint ! Local heap size hint - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - INTEGER :: est_num_entries ! Estimated # of entries in group - INTEGER :: est_name_len ! Estimated length of entry name - CHARACTER(LEN=NAME_BUF_SIZE) :: filename = 'fixx.h5' - INTEGER(SIZE_T) :: LIFECYCLE_LOCAL_HEAP_SIZE_HINT = 256 - INTEGER :: LIFECYCLE_MAX_COMPACT = 4 - INTEGER :: LIFECYCLE_MIN_DENSE = 3 - INTEGER :: LIFECYCLE_EST_NUM_ENTRIES = 4 - INTEGER :: LIFECYCLE_EST_NAME_LEN=8 - CHARACTER(LEN=3) :: LIFECYCLE_TOP_GROUP="top" -! These value are taken from H5Gprivate.h - INTEGER :: H5G_CRT_GINFO_MAX_COMPACT = 8 - INTEGER :: H5G_CRT_GINFO_MIN_DENSE = 6 - INTEGER :: H5G_CRT_GINFO_EST_NUM_ENTRIES = 4 - INTEGER :: H5G_CRT_GINFO_EST_NAME_LEN = 8 - logical :: cleanup - -! WRITE(*,*) 'group lifecycle' - - ! Create file - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl2) - CALL check("H5Fcreate_f",error,total_error) - - ! Close file - CALL H5Fclose_f(fid,error) - CALL check("H5Fclose_f",error,total_error) - - ! Get size of file as empty - ! if((empty_size = h5_get_file_size(filename)) < 0) TEST_ERROR - - ! Re-open file - - CALL H5Fopen_f(filename, H5F_ACC_RDWR_F, fid, error,access_prp=fapl2) - CALL check("H5Fopen_f",error,total_error) - - - ! Set up group creation property list - CALL H5Pcreate_f(H5P_GROUP_CREATE_F,gcpl,error) - CALL check("H5Pcreate_f",error,total_error) - - - ! Query default group creation property settings - CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) - CALL check("H5Pget_local_heap_size_hint_f",error,total_error) - CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),0,total_error) - - CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) - CALL check("H5Pget_link_phase_change_f", error, total_error) - CALL verify("H5Pget_link_phase_change_f", max_compact, H5G_CRT_GINFO_MAX_COMPACT,total_error) - CALL verify("H5Pget_link_phase_change_f", min_dense, H5G_CRT_GINFO_MIN_DENSE,total_error) - - - CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) - CALL check("H5Pget_est_link_info_f", error, total_error) - CALL verify("H5Pget_est_link_info_f", est_num_entries, H5G_CRT_GINFO_EST_NUM_ENTRIES,total_error) - CALL verify("H5Pget_est_link_info_f", est_name_len, H5G_CRT_GINFO_EST_NAME_LEN,total_error) - - - ! Set GCPL parameters - - CALL H5Pset_local_heap_size_hint_f(gcpl, LIFECYCLE_LOCAL_HEAP_SIZE_HINT, error) - CALL check("H5Pset_local_heap_size_hint_f", error, total_error) - CALL H5Pset_link_phase_change_f(gcpl, LIFECYCLE_MAX_COMPACT, LIFECYCLE_MIN_DENSE, error) - CALL check("H5Pset_link_phase_change_f", error, total_error) - CALL H5Pset_est_link_info_f(gcpl, LIFECYCLE_EST_NUM_ENTRIES, LIFECYCLE_EST_NAME_LEN, error) - CALL check("H5Pset_est_link_info_f", error, total_error) - - ! Create group for testing lifecycle - - CALL H5Gcreate_f(fid, LIFECYCLE_TOP_GROUP, gid, error, gcpl_id=gcpl) - CALL check("H5Gcreate_f", error, total_error) - - ! Query group creation property settings - - CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) - CALL check("H5Pget_local_heap_size_hint_f",error,total_error) - CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),INT(LIFECYCLE_LOCAL_HEAP_SIZE_HINT),total_error) - - CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) - CALL check("H5Pget_link_phase_change_f", error, total_error) - CALL verify("H5Pget_link_phase_change_f", max_compact, LIFECYCLE_MAX_COMPACT,total_error) - CALL verify("H5Pget_link_phase_change_f", min_dense, LIFECYCLE_MIN_DENSE,total_error) - - CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) - CALL check("H5Pget_est_link_info_f", error, total_error) - CALL verify("H5Pget_est_link_info_f", est_num_entries, LIFECYCLE_EST_NUM_ENTRIES,total_error) - CALL verify("H5Pget_est_link_info_f", est_name_len, LIFECYCLE_EST_NAME_LEN,total_error) - - - - ! Close top group - CALL H5Gclose_f(gid, error) - CALL check("H5Gclose_f", error, total_error) - - ! Unlink top group - - CALL H5Ldelete_f(fid, LIFECYCLE_TOP_GROUP, error) - CALL check("H5Ldelete_f", error, total_error) - - ! Close GCPL - CALL H5Pclose_f(gcpl, error) - CALL check("H5Pclose_f", error, total_error) - - ! Close file - CALL H5Fclose_f(fid,error) - CALL check("H5Fclose_f",error,total_error) - - IF(cleanup) CALL h5_cleanup_f("fixx", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - END SUBROUTINE lifecycle - -!------------------------------------------------------------------------- -! * Function: cklinks -! * -! * Purpose: Open the file created in the first step and check that the -! * links look correct. -! * -! * Return: Success: 0 -! * -! * Failure: -1 -! * -! * Programmer: M.S. Breitenfeld -! * April 14, 2008 -! * -! * Modifications: Modified original C code -! * -! *------------------------------------------------------------------------- -! - - - SUBROUTINE cklinks(fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER :: error - - INTEGER(HID_T) :: file -! H5O_info_t oinfo1, oinfo2; -! H5L_info_t linfo2; - - CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' - -! TYPE(C_PTR) :: linkval - - LOGICAL :: Lexists - - ! Open the file - CALL H5Fopen_f(filename, H5F_ACC_RDONLY_F, file, error,access_prp=fapl) - CALL check("H5Fopen_f",error,total_error) - - - ! Hard link -!!$ IF(H5Oget_info_by_name(file, "d1", &oinfo1, H5P_DEFAULT) < 0) FAIL_STACK_ERROR -!!$ IF(H5Oget_info_by_name(file, "grp1/hard", &oinfo2, H5P_DEFAULT) < 0) FAIL_STACK_ERROR -!!$ IF(H5O_TYPE_DATASET != oinfo2.type) { -!!$ H5_FAILED(); -!!$ printf(" %d: Unexpected object type should have been a dataset\n", __LINE__); -!!$ TEST_ERROR -!!$ } end if -!!$ if(H5F_addr_ne(oinfo1.addr, oinfo2.addr)) { -!!$ H5_FAILED(); -!!$ puts(" Hard link test failed. Link seems not to point to the "); -!!$ puts(" expected file location."); -!!$ TEST_ERROR -!!$ } end if - - - CALL H5Lexists_f(file,"d1",Lexists, error) - CALL verify("H5Lexists", Lexists,.TRUE.,total_error) - - CALL H5Lexists_f(file,"grp1/hard",Lexists, error) - CALL verify("H5Lexists", Lexists,.TRUE.,total_error) - - ! Cleanup - CALL H5Fclose_f(file,error) - CALL check("H5Fclose_f",error,total_error) - -END SUBROUTINE cklinks - - -!------------------------------------------------------------------------- -! * Function: delete_by_idx -! * -! * Purpose: Create a group with creation order indices and test deleting -! * links by index. -! * -! * Return: Total error -! * -! * C Programmer: Quincey Koziol -! * Tuesday, November 14, 2006 -! * -! * Adapted to FORTRAN: M.S. Breitenfeld -! * March 3, 2008 -! * -! *------------------------------------------------------------------------- -! -SUBROUTINE delete_by_idx(cleanup, fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - - INTEGER(HID_T) :: file_id ! File ID - INTEGER(HID_T) :: group_id ! Group ID - INTEGER(HID_T) :: gcpl_id ! Group creation property list ID - - INTEGER :: idx_type ! Type of index to operate on - LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) - ! Use index on creation order values - INTEGER :: max_compact ! Maximum # of links to store in group compactly - INTEGER :: min_dense ! Minimum # of links to store in group "densely" - - CHARACTER(LEN=7) :: objname ! Object name - CHARACTER(LEN=8) :: filename = 'file0.h5' ! File name - CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" - - LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER(SIZE_T) :: val_size - INTEGER :: link_type - INTEGER(HADDR_T) :: address - - INTEGER :: u ! Local index variable - INTEGER :: Input1, i - INTEGER(HID_T) :: group_id2 - INTEGER(HID_T) :: grp - INTEGER :: iorder ! Order within in the index - CHARACTER(LEN=2) :: chr2 - INTEGER :: error - INTEGER :: id_type - ! - ! - ! - CHARACTER(LEN=80) :: fix_filename1 - CHARACTER(LEN=80) :: fix_filename2 - INTEGER(HSIZE_T) :: htmp - - LOGICAL :: cleanup - - DO i = 1, 80 - fix_filename1(i:i) = " " - fix_filename2(i:i) = " " - ENDDO - - ! Loop over operating on different indices on link fields - DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F - ! Loop over operating in different orders - DO iorder = H5_ITER_INC_F, H5_ITER_DEC_F - ! Loop over using index for creation order value - DO i = 1, 2 - ! Print appropriate test message -!!$ IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN -!!$ IF(iorder == H5_ITER_INC_F)THEN -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/o creation order index" -!!$ ENDIF -!!$ ELSE -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/o creation order index" -!!$ ENDIF -!!$ ENDIF -!!$ ELSE -!!$ IF(iorder == H5_ITER_INC_F)THEN -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/o creation order index" -!!$ ENDIF -!!$ ELSE -!!$ IF(use_index(i))THEN -!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/creation order index" -!!$ ELSE -!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/o creation order index" -!!$ ENDIF -!!$ ENDIF -!!$ ENDIF - - ! Create file - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, access_prp=fapl) - CALL check("delete_by_idx.H5Fcreate_f", error, total_error) - - ! Create group creation property list - CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) - CALL check("delete_by_idx.H5Pcreate_f", error, total_error) - - ! Set creation order tracking & indexing on group - IF(use_index(i))THEN - Input1 = H5P_CRT_ORDER_INDEXED_F - ELSE - Input1 = 0 - ENDIF - - CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) - CALL check("delete_by_idx.H5Pset_link_creation_order_f", error, total_error) - - ! Create group with creation order tracking on - CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) - CALL check("delete_by_idx.H5Gcreate_f", error, total_error) - - ! Query the group creation properties - CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) - CALL check("delete_by_idx.H5Pget_link_phase_change_f", error, total_error) - - - ! Delete links from one end - - ! Check for deletion on empty group - CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) - CALL verify("delete_by_idx.H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) - ! Create several links, up to limit of compact form - DO u = 0, max_compact-1 - ! Make name for link - WRITE(chr2,'(I2.2)') u - objname = 'fill '//chr2 - - ! Create hard link, with group object - CALL H5Gcreate_f(group_id, objname, group_id2, error) - CALL check("delete_by_idx.H5Gcreate_f", error, total_error) - CALL H5Gclose_f(group_id2, error) - CALL check("delete_by_idx.H5Gclose_f", error, total_error) - - ! Verify link information for new link - CALL link_info_by_idx_check(group_id, objname, u, & - .TRUE., use_index(i), total_error) - ENDDO - - ! Verify state of group (compact) - ! IF(H5G_has_links_test(group_id, NULL) != TRUE) TEST_ERROR - - ! Check for out of bound deletion - htmp =9 -!EP CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(u,HSIZE_T), error) - CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, htmp, error) - CALL verify("H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) - - - ! Delete links from compact group - - DO u = 0, (max_compact - 1) -1 - ! Delete first link in appropriate order - CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) - CALL check("H5Ldelete_by_idx_f", error, total_error) - ! Verify the link information for first link in appropriate order - ! HDmemset(&linfo, 0, sizeof(linfo)); - - CALL H5Lget_info_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), & - link_type, f_corder_valid, corder, cset, address, val_size, error) - - CALL H5Oopen_by_addr_f(group_id, address, grp, error) - CALL check("H5Oopen_by_addr_f", error, total_error) - - CALL H5Iget_type_f(grp, id_type, error) - CALL check("H5Iget_type_f", error, total_error) - - CALL verify("H5Iget_type_f", id_type, H5I_GROUP_F, total_error) - - CALL H5Gclose_f(grp, error) - CALL check("H5Gclose_f", error, total_error) - - CALL verify("H5Lget_info_by_idx_f", f_corder_valid, .TRUE., total_error) - - CALL verify("H5Lget_info_by_idx_f", H5L_TYPE_HARD_F, link_type, total_error) - IF(iorder.EQ.H5_ITER_INC_F)THEN - CALL verify("H5Lget_info_by_idx_f", corder, u+1, total_error) - ELSE - CALL verify("H5Lget_info_by_idx_f", corder, (max_compact - (u + 2)), total_error) - ENDIF - - CALL verify("H5Lget_info_by_idx_f",cset, H5T_CSET_ASCII_F, total_error) - - - - ! Verify the name for first link in appropriate order - ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); -!!$ size_tmp = 20 -!!$ CALL H5Lget_name_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), size_tmp, tmpname, error) -!!$ CALL check("delete_by_idx.H5Lget_name_by_idx_f", error, total_error) -!!$ -!!$ IF(order .EQ. H5_ITER_INC_F)THEN -!!$ WRITE(chr2,'(I2.2)') u + 1 -!!$ ELSE -!!$ WRITE(chr2,'(I2.2)') (max_compact - (u + 2)) -!!$ ENDIF -!!$ objname = 'fill '//chr2 -!!$ PRINT*,objname, tmpname -!!$ CALL verify("delete_by_idx.H5Lget_name_by_idx_f", objname, tmpname, total_error) - ENDDO - - ! Close the group - CALL H5Gclose_f(group_id, error) - CALL check("delete_by_idx.H5Gclose_f", error, total_error) - - ! Close the group creation property list - CALL H5Pclose_f(gcpl_id, error) - CALL check("delete_by_idx.H5Gclose_f", error, total_error) - - ! Close the file - CALL H5Fclose_f(file_id, error) - CALL check("delete_by_idx.H5Gclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f("file0", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - ENDDO - ENDDO - ENDDO - - -END SUBROUTINE delete_by_idx - - - -!------------------------------------------------------------------------- -! * Function: link_info_by_idx_check -! * -! * Purpose: Support routine for link_info_by_idx, to verify the link -! * info is correct for a link -! * -! * Note: This routine assumes that the links have been inserted in the -! * group in alphabetical order. -! * -! * Return: Success: 0 -! * Failure: -1 -! * -! * Programmer: Quincey Koziol -! * Tuesday, November 7, 2006 -! * -! *------------------------------------------------------------------------- -! -SUBROUTINE link_info_by_idx_check(group_id, linkname, n, & - hard_link, use_index, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: group_id - CHARACTER(LEN=*), INTENT(IN) :: linkname - INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN) :: hard_link - LOGICAL, INTENT(IN) :: use_index - - LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute - INTEGER :: corder ! Is a positive integer containing the creation order of the attribute - INTEGER :: cset ! Indicates the character set used for the attribute’s name - INTEGER :: link_type - INTEGER(HADDR_T) :: address - INTEGER(SIZE_T) :: val_size ! Indicates the size, in the number of characters, of the attribute - - CHARACTER(LEN=7) :: tmpname ! Temporary link name - CHARACTER(LEN=3) :: tmpname_small ! to small temporary link name - CHARACTER(LEN=10) :: tmpname_big ! to big temporary link name - - CHARACTER(LEN=7) :: valname ! Link value name - CHARACTER(LEN=2) :: chr2 - INTEGER(SIZE_T) :: size_tmp - INTEGER :: error - - ! Make link value for increasing/native order queries - - WRITE(chr2,'(I2.2)') n - valname = 'valn.'//chr2 - - ! Verify the link information for first link, in increasing creation order - ! HDmemset(&linfo, 0, sizeof(linfo)); - CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(0,HSIZE_T), & - link_type, f_corder_valid, corder, cset, address, val_size, error) - CALL check("H5Lget_info_by_idx_f", error, total_error) - CALL verify("H5Lget_info_by_idx_f", corder, 0, total_error) - - ! Verify the link information for new link, in increasing creation order - ! HDmemset(&linfo, 0, sizeof(linfo)); - CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), & - link_type, f_corder_valid, corder, cset, address, val_size, error) - CALL check("H5Lget_info_by_idx_f", error, total_error) - CALL verify("H5Lget_info_by_idx_f", corder, n, total_error) - - ! Verify value for new soft link, in increasing creation order -!!$ IF(hard_link)THEN -!!$ ! HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE); -!!$ -!!$ CALL H5Lget_val_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, n, tmpval, INT(7,SIZE_T),error) -!!$ CALL check("H5Lget_val_by_idx",error,total_error) -!!$ -!!$! IF(HDstrcmp(valname, tmpval)) TEST_ERROR -!!$ ENDIF - - ! Verify the name for new link, in increasing creation order - ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); - - ! The actual size of tmpname should be 7 - - CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_small, error, size_tmp) - CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & - linkname(1:LEN(tmpname_small)), tmpname_small(1:LEN(tmpname_small)), total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) - ! try it with the correct size - CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname, error, size=size_tmp) - CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & - linkname(1:LEN(tmpname)), tmpname(1:LEN(tmpname)), total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) - - CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_big, error, size_tmp) - CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", & - linkname(1:7), tmpname_big(1:7), total_error) - CALL verify("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) - - ! Try with a buffer set to small - - - END SUBROUTINE link_info_by_idx_check - - -!------------------------------------------------------------------------- -! * Function: test_lcpl -! * -! * Purpose: Tests Link Creation Property Lists -! * -! * Return: Success: 0 -! * Failure: number of errors -! * -! * Programmer: M.S. Breitenfeld -! * Modified C routine -! * March 12, 2008 -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - - SUBROUTINE test_lcpl(cleanup, fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - LOGICAL :: cleanup - - INTEGER(HID_T) :: file_id - INTEGER(HID_T) :: group_id - INTEGER(HID_T) :: space_id, data_space - INTEGER(HID_T) :: dset_id - INTEGER(HID_T) :: type_id - INTEGER(HID_T) :: lcpl_id - - INTEGER :: cset ! Indicates the character set used for the link’s name. - INTEGER :: corder ! Specifies the link’s creation order position. - LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. - INTEGER :: link_type ! Specifies the link class: - ! H5L_TYPE_HARD_F - Hard link - ! H5L_TYPE_SOFT_F - Soft link - ! H5L_TYPE_EXTERNAL_F - External link - ! H5L_TYPE_ERROR _F - Error - INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to - INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value - - CHARACTER(LEN=1024) :: filename = 'tempfile.h5' - INTEGER, PARAMETER :: TEST6_DIM1 = 8, TEST6_DIM2 = 7 - INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/) - - INTEGER :: encoding - INTEGER :: error - LOGICAL :: Lexists - INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: extend_dim = (/TEST6_DIM1-2,TEST6_DIM2-3/) - INTEGER(HSIZE_T), DIMENSION(1:2) :: dimsout, maxdimsout ! dimensions - - INTEGER :: i - INTEGER :: tmp1, tmp2 - INTEGER(HID_T) :: crp_list - -! WRITE(*,*) "link creation property lists (w/new group format)" - - - ! Actually, intermediate group creation is tested elsewhere (tmisc). - ! * Here we only need to test the character encoding property - - ! Create file - ! h5_fixname(FILENAME[0], fapl, filename, sizeof filename); - - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) - CALL check("H5Fcreate_f", error, total_error) - - - ! Create and link a group with the default LCPL - - CALL H5Gcreate_f(file_id, "/group", group_id, error) - CALL check("H5Gcreate_f", error, total_error) - - - ! Check that its character encoding is the default - - CALL H5Lget_info_f(file_id, "group", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error, H5P_DEFAULT_F) - -! File-wide default character encoding can not yet be set via the file -! * creation property list and is always ASCII. -!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- - - CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) - - ! Create and commit a datatype with the default LCPL - CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) - CALL check("h5tcopy_f",error,total_error) - CALL h5tcommit_f(file_id, "/type", type_id, error) - CALL check("h5tcommit_f", error, total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f", error, total_error) - - - ! Check that its character encoding is the default - CALL H5Lget_info_f(file_id, "type", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("h5tclose_f", error, total_error) - -! File-wide default character encoding can not yet be set via the file -! * creation property list and is always ASCII. -!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- - - CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) - - ! Create a dataspace - CALL h5screate_simple_f(2, dims, space_id, error) - CALL check("h5screate_simple_f",error,total_error) - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) - CALL h5pset_chunk_f(crp_list, 2, dims, error) - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) - CALL h5pset_chunk_f(crp_list, 2, dims, error) - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) - CALL h5pset_chunk_f(crp_list, 2, dims, error) - - ! Create a dataset using the default LCPL - CALL h5dcreate_f(file_id, "/dataset", H5T_NATIVE_INTEGER, space_id, dset_id, error, crp_list) - CALL check("h5dcreate_f", error, total_error) - - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - - ! Reopen - - CALL H5Dopen_f(file_id, "/dataset", dset_id, error) - CALL check("h5dopen_f", error, total_error) - - ! Extend the dataset - CALL H5Dset_extent_f(dset_id, extend_dim, error) - CALL check("H5Dset_extent_f", error, total_error) - ! Verify the dataspaces - ! - !Get dataset's dataspace handle. - ! - CALL h5dget_space_f(dset_id, data_space, error) - CALL check("h5dget_space_f",error,total_error) - - CALL h5sget_simple_extent_dims_f(data_space, dimsout, maxdimsout, error) - CALL check("h5sget_simple_extent_dims_f",error, total_error) - - DO i = 1, 2 - tmp1 = INT(dimsout(i)) - tmp2 = INT(extend_dim(i)) - CALL verify("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) - tmp1 = INT(maxdimsout(i)) - tmp2 = INT(dims(i)) - CALL verify("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) - ENDDO - - ! close data set - - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - - ! Check that its character encoding is the default - CALL H5Lget_info_f(file_id, "dataset", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - -! File-wide default character encoding can not yet be set via the file -! * creation property list and is always ASCII. -!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- - - CALL verify("h5tclose_f",cset, H5T_CSET_ASCII_F,total_error) - - ! Create a link creation property list with the UTF-8 character encoding - CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) - CALL check("h5Pcreate_f",error,total_error) - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - - ! Create and link a group with the new LCPL - CALL H5Gcreate_f(file_id, "/group2", group_id, error,lcpl_id=lcpl_id) - CALL check("H5Gcreate_f", error, total_error) - CALL H5Gclose_f(group_id, error) - CALL check("H5Gclose_f", error, total_error) - - - ! Check that its character encoding is UTF-8 - CALL H5Lget_info_f(file_id, "group2", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) - - - ! Create and commit a datatype with the new LCPL - - CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) - CALL check("h5tcopy_f",error,total_error) - CALL h5tcommit_f(file_id, "/type2", type_id, error, lcpl_id=lcpl_id) - CALL check("h5tcommit_f", error, total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f", error, total_error) - - - ! Check that its character encoding is UTF-8 - CALL H5Lget_info_f(file_id, "type2", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) - - ! Create a dataset using the new LCPL - CALL h5dcreate_f(file_id, "/dataset2", H5T_NATIVE_INTEGER, space_id, dset_id, error,lcpl_id=lcpl_id) - CALL check("h5dcreate_f", error, total_error) - - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - - CALL H5Pget_char_encoding_f(lcpl_id, encoding, error) - CALL check("H5Pget_char_encoding_f", error, total_error) - CALL verify("H5Pget_char_encoding_f", encoding, H5T_CSET_UTF8_F, total_error) - - ! Check that its character encoding is UTF-8 - CALL H5Lget_info_f(file_id, "dataset2", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f2",cset, H5T_CSET_UTF8_F,total_error) - - ! Create a new link to the dataset with a different character encoding. - CALL H5Pclose_f(lcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - - CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) - CALL check("h5Pcreate_f",error,total_error) - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - CALL H5Lcreate_hard_f(file_id, "/dataset2", file_id, "/dataset2_link", error, lcpl_id) - CALL check("H5Lcreate_hard_f",error, total_error) - - CALL H5Lexists_f(file_id,"/dataset2_link",Lexists, error) - CALL check("H5Lexists",error, total_error) - CALL verify("H5Lexists", Lexists,.TRUE.,total_error) - - ! Check that its character encoding is ASCII - CALL H5Lget_info_f(file_id, "/dataset2_link", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) - - ! Check that the first link's encoding hasn't changed - - CALL H5Lget_info_f(file_id, "/dataset2", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f3",cset, H5T_CSET_UTF8_F,total_error) - - - ! Make sure that LCPLs work properly for other API calls: - ! H5Lcreate_soft - - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - CALL H5Lcreate_soft_f("dataset2", file_id, "slink_to_dset2",error,lcpl_id) - CALL check("H5Lcreate_soft_f", error, total_error) - - CALL H5Lget_info_f(file_id, "slink_to_dset2", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) - - - ! H5Lmove - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - - CALL H5Lmove_f(file_id, "slink_to_dset2", file_id, "moved_slink", error, lcpl_id, H5P_DEFAULT_F) - CALL check("H5Lmove_f",error, total_error) - - CALL H5Lget_info_f(file_id, "moved_slink", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) - - - ! H5Lcopy - - CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) - CALL check("H5Pset_char_encoding_f",error, total_error) - - CALL H5Lcopy_f(file_id, "moved_slink", file_id, "copied_slink", error, lcpl_id) - - CALL H5Lget_info_f(file_id, "copied_slink", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) - - - ! H5Lcreate_external - - CALL H5Lcreate_external_f("filename", "path", file_id, "extlink", error, lcpl_id) - CALL check("H5Lcreate_external_f", error, total_error) - - CALL H5Lget_info_f(file_id, "extlink", & - cset, corder, f_corder_valid, link_type, address, val_size, & - error) - CALL check("H5Lget_info_f", error, total_error) - CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) - - - ! Close open IDs - - CALL H5Pclose_f(lcpl_id, error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Sclose_f(space_id, error) - CALL check("h5Sclose_f",error,total_error) - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f("tempfile", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - -END SUBROUTINE test_lcpl - -SUBROUTINE objcopy(fapl, total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T), INTENT(IN) :: fapl - - INTEGER(HID_T) :: fapl2, pid - - INTEGER :: flag, cpy_flags - - INTEGER :: error - - flag = H5O_COPY_SHALLOW_HIERARCHY_F - -! Copy the file access property list - CALL H5Pcopy_f(fapl, fapl2, error) - CALL check("H5Pcopy_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(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) - - ! create property to pass copy options - CALL h5pcreate_f(H5P_OBJECT_COPY_F, pid, error) - CALL check("h5pcreate_f",error, total_error) - - ! set options for object copy - CALL H5Pset_copy_object_f(pid, flag, error) - CALL check("H5Pset_copy_object_f",error, total_error) - - ! Verify object copy flags - CALL H5Pget_copy_object_f(pid, cpy_flags, error) - CALL check("H5Pget_copy_object_f",error, total_error) - CALL verify("H5Pget_copy_object_f", cpy_flags, flag, total_error) - -!!$ -!!$ CALL test_copy_option(fcpl_src, fcpl_dst, my_fapl, H5O_COPY_WITHOUT_ATTR_FLAG, -!!$ FALSE, "H5Ocopy(): without attributes"); - - CALL lapl_nlinks(fapl2, total_error) - -END SUBROUTINE objcopy - - -!------------------------------------------------------------------------- -! * Function: lapl_nlinks -! * -! * Purpose: Check that the maximum number of soft links can be adjusted -! * by the user using the Link Access Property List. -! * -! * Return: Success: 0 -! * -! * Failure: -1 -! * -! * Programmer: James Laird -! * Tuesday, June 6, 2006 -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - -SUBROUTINE lapl_nlinks( fapl, total_error) - - IMPLICIT NONE - INTEGER(HID_T), INTENT(IN) :: fapl - INTEGER, INTENT(INOUT) :: total_error - - INTEGER :: error - - INTEGER(HID_T) :: fid = (-1) ! File ID - INTEGER(HID_T) :: gid = (-1), gid2 = (-1) ! Group IDs - INTEGER(HID_T) :: plist = (-1) ! lapl ID - INTEGER(HID_T) :: tid = (-1) ! Other IDs - INTEGER(HID_T) :: gapl = (-1), dapl = (-1), tapl = (-1) ! Other property lists - - CHARACTER(LEN=7) :: objname ! Object name - INTEGER(size_t) :: name_len ! Length of object name - CHARACTER(LEN=12) :: filename = 'TestLinks.h5' - INTEGER(size_t) :: nlinks ! nlinks for H5Pset_nlinks - INTEGER(size_t) :: buf_size = 7 - -! WRITE(*,*) "adjusting nlinks with LAPL (w/new group format)" - - - ! Create file - CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl) - CALL check(" lapl_nlinks.h5fcreate_f",error,total_error) - - ! Create group with short name in file (used as target for links) - CALL H5Gcreate_f(fid, "final", gid, error) - CALL check(" lapl_nlinks.H5Gcreate_f", error, total_error) - - ! Create chain of soft links to existing object (limited) - CALL H5Lcreate_soft_f("final", fid, "soft1", error) - CALL H5Lcreate_soft_f("soft1", fid, "soft2", error) - CALL H5Lcreate_soft_f("soft2", fid, "soft3", error) - CALL H5Lcreate_soft_f("soft3", fid, "soft4", error) - CALL H5Lcreate_soft_f("soft4", fid, "soft5", error) - CALL H5Lcreate_soft_f("soft5", fid, "soft6", error) - CALL H5Lcreate_soft_f("soft6", fid, "soft7", error) - CALL H5Lcreate_soft_f("soft7", fid, "soft8", error) - CALL H5Lcreate_soft_f("soft8", fid, "soft9", error) - CALL H5Lcreate_soft_f("soft9", fid, "soft10", error) - CALL H5Lcreate_soft_f("soft10", fid, "soft11", error) - CALL H5Lcreate_soft_f("soft11", fid, "soft12", error) - CALL H5Lcreate_soft_f("soft12", fid, "soft13", error) - CALL H5Lcreate_soft_f("soft13", fid, "soft14", error) - CALL H5Lcreate_soft_f("soft14", fid, "soft15", error) - CALL H5Lcreate_soft_f("soft15", fid, "soft16", error) - CALL H5Lcreate_soft_f("soft16", fid, "soft17", error) - - ! Close objects - CALL H5Gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Open file - - CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) - CALL check("h5open_f",error,total_error) - - ! Create LAPL with higher-than-usual nlinks value - ! Create a non-default lapl with udata set to point to the first group - - CALL H5Pcreate_f(H5P_LINK_ACCESS_F,plist,error) - CALL check("h5Pcreate_f",error,total_error) - nlinks = 20 - CALL H5Pset_nlinks_f(plist, nlinks, error) - CALL check("H5Pset_nlinks_f",error,total_error) - ! Ensure that nlinks was set successfully - nlinks = 0 - CALL H5Pget_nlinks_f(plist, nlinks, error) - CALL check("H5Pset_nlinks_f",error,total_error) - CALL verify("H5Pset_nlinks_f",INT(nlinks), 20, total_error) - - - ! Open object through what is normally too many soft links using - ! * new property list - - CALL H5Oopen_f(fid,"soft17",gid,error,plist) - CALL check("H5Oopen_f",error,total_error) - - ! Check name - CALL h5iget_name_f(gid, objname, buf_size, name_len, error) - CALL check("h5iget_name_f",error,total_error) - CALL verify("h5iget_name_f", TRIM(objname),"/soft17", total_error) - ! Create group using soft link - CALL H5Gcreate_f(gid, "new_soft", gid2, error) - CALL check("H5Gcreate_f", error, total_error) - - ! Close groups - CALL H5Gclose_f(gid2, error) - CALL check("H5Gclose_f", error, total_error) - CALL H5Gclose_f(gid, error) - CALL check("H5Gclose_f", error, total_error) - - - ! Set nlinks to a smaller number - nlinks = 4 - CALL H5Pset_nlinks_f(plist, nlinks, error) - CALL check("H5Pset_nlinks_f", error, total_error) - - ! Ensure that nlinks was set successfully - nlinks = 0 - - CALL H5Pget_nlinks_f(plist, nlinks, error) - CALL check("H5Pget_nlinks_f",error,total_error) - CALL verify("H5Pget_nlinks_f", INT(nlinks), 4, total_error) - - ! Try opening through what is now too many soft links - - CALL H5Oopen_f(fid,"soft5",gid,error,plist) - CALL verify("H5Oopen_f", error, -1, total_error) ! should fail - - ! Open object through lesser soft link - CALL H5Oopen_f(fid,"soft4",gid,error,plist) - CALL check("H5Oopen_",error,total_error) - - ! Check name - CALL h5iget_name_f(gid, objname, buf_size, name_len, error) - CALL check("h5iget_name_f",error,total_error) - CALL verify("h5iget_name_f", TRIM(objname),"/soft4", total_error) - - ! Test other functions that should use a LAPL - nlinks = 20 - CALL H5Pset_nlinks_f(plist, nlinks, error) - CALL check("H5Pset_nlinks_f", error, total_error) - - ! Try copying and moving when both src and dst contain many soft links - ! * using a non-default LAPL - ! - CALL H5Lcopy_f(fid, "soft17", fid, "soft17/newer_soft", error, H5P_DEFAULT_F, plist) - CALL check("H5Lcopy_f",error,total_error) - - CALL H5Lmove_f(fid, "soft17/newer_soft", fid, "soft17/newest_soft", error, lapl_id=plist) - CALL check("H5Lmove_f",error, total_error) - - ! H5Olink - CALL H5Olink_f(gid, fid, "soft17/link_to_group", error, H5P_DEFAULT_F, plist) - CALL check("H5Olink_f", error, total_error) - - ! H5Lcreate_hard and H5Lcreate_soft - CALL H5Lcreate_hard_f(fid, "soft17", fid, "soft17/link2_to_group", error, H5P_DEFAULT_F, plist) - CALL check("H5Lcreate_hard_f", error, total_error) - - - CALL H5Lcreate_soft_f("/soft4", fid, "soft17/soft_link",error, H5P_DEFAULT_F, plist) - CALL check("H5Lcreate_soft_f", error, total_error) - - ! H5Ldelete - CALL h5ldelete_f(fid, "soft17/soft_link", error, plist) - CALL check("H5Ldelete_f", error, total_error) - -!!$ H5Lget_val and H5Lget_info -!!$ if(H5Lget_val(fid, "soft17", NULL, (size_t)0, plist) < 0) TEST_ERROR -!!$ if(H5Lget_info(fid, "soft17", NULL, plist) < 0) TEST_ERROR -!!$ - - ! H5Lcreate_external and H5Lcreate_ud - CALL H5Lcreate_external_f("filename", "path", fid, "soft17/extlink", error, H5P_DEFAULT_F, plist) - CALL check("H5Lcreate_external_f", error, total_error) - -!!$ if(H5Lregister(UD_rereg_class) < 0) TEST_ERROR -!!$ if(H5Lcreate_ud(fid, "soft17/udlink", UD_HARD_TYPE, NULL, (size_t)0, H5P_DEFAULT, plist) < 0) TEST_ERROR -!!$ - ! Close plist - CALL h5pclose_f(plist, error) - CALL check("h5pclose_f", error, total_error) - - ! Create a datatype and dataset as targets inside the group - CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error) - CALL check("h5tcopy_f",error,total_error) - CALL h5tcommit_f(gid, "datatype", tid, error) - CALL check("h5tcommit_f", error, total_error) - CALL h5tclose_f(tid, error) - CALL check("h5tclose_f", error, total_error) - -!!$ -!!$ dims[0] = 2; -!!$ dims[1] = 2; -!!$ if((sid = H5Screate_simple(2, dims, NULL)) < 0) TEST_ERROR -!!$ if((did = H5Dcreate2(gid, "dataset", H5T_NATIVE_INT, sid, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR -!!$ if(H5Dclose(did) < 0) TEST_ERROR -!!$ - ! Close group - CALL h5gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - -!!$ -!!$ Try to open the objects using too many symlinks with default *APLs -!!$ H5E_BEGIN_TRY { -!!$ if((gid = H5Gopen2(fid, "soft17", H5P_DEFAULT)) >= 0) -!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") -!!$ if((tid = H5Topen2(fid, "soft17/datatype", H5P_DEFAULT)) >= 0) -!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") -!!$ if((did = H5Dopen2(fid, "soft17/dataset", H5P_DEFAULT)) >= 0) -!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") -!!$ } H5E_END_TRY -!!$ - ! Create property lists with nlinks set - - CALL H5Pcreate_f(H5P_GROUP_ACCESS_F,gapl,error) - CALL check("h5Pcreate_f",error,total_error) - CALL H5Pcreate_f(H5P_DATATYPE_ACCESS_F,tapl,error) - CALL check("h5Pcreate_f",error,total_error) - CALL H5Pcreate_f(H5P_DATASET_ACCESS_F,dapl,error) - CALL check("h5Pcreate_f",error,total_error) - - - nlinks = 20 - CALL H5Pset_nlinks_f(gapl, nlinks, error) - CALL check("H5Pset_nlinks_f", error, total_error) - CALL H5Pset_nlinks_f(tapl, nlinks, error) - CALL check("H5Pset_nlinks_f", error, total_error) - CALL H5Pset_nlinks_f(dapl, nlinks, error) - CALL check("H5Pset_nlinks_f", error, total_error) - - ! We should now be able to use these property lists to open each kind - ! * of object. - ! - - CALL H5Gopen_f(fid, "soft17", gid, error, gapl) - CALL check("H5Gopen_f",error,total_error) - - CALL H5Topen_f(fid, "soft17/datatype", tid, error, tapl) - CALL check("H5Gopen_f",error,total_error) - -!!$ if((did = H5Dopen2(fid, "soft17/dataset", dapl)) < 0) TEST_ERROR - - ! Close objects - - CALL h5gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - CALL h5tclose_f(tid, error) - CALL check("h5tclose_f", error, total_error) - -!!$ if(H5Dclose(did) < 0) TEST_ERROR -!!$ - ! Close plists - - CALL h5pclose_f(gapl, error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(tapl, error) - CALL check("h5pclose_f", error, total_error) - -!!$ if(H5Pclose(dapl) < 0) TEST_ERROR -!!$ -!!$ Unregister UD hard link class -!!$ if(H5Lunregister(UD_HARD_TYPE) < 0) TEST_ERROR -!!$ - - ! Close file - CALL H5Fclose_f(fid, error) - CALL check("H5Fclose_f", error, total_error) - -END SUBROUTINE lapl_nlinks - -END MODULE TH5G_1_8 diff --git a/fortran/test/tH5I.F90 b/fortran/test/tH5I.F90 new file mode 100644 index 0000000..97c48c6 --- /dev/null +++ b/fortran/test/tH5I.F90 @@ -0,0 +1,321 @@ +!****h* root/fortran/test/tH5I.f90 +! +! NAME +! tH5I.f90 +! +! FUNCTION +! Basic testing of Fortran H5I APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! identifier_test +! +!***** +MODULE TH5I + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + + SUBROUTINE identifier_test(cleanup, total_error) + +! This subroutine tests following functionalities: h5iget_type_f + + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=6), PARAMETER :: filename = "itestf" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=10), PARAMETER :: dsetname = "/itestdset" ! Dataset name + CHARACTER(LEN=10), PARAMETER :: groupname = "itestgroup"! group name + CHARACTER(LEN=10), PARAMETER :: aname = "itestattr"! group name + + + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: new_file_id ! File identifier + INTEGER(HID_T) :: group_id ! group identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dspace_id ! Dataspace identifier + INTEGER(HID_T) :: attr_id ! Datatype attribute identifier + INTEGER(HID_T) :: aspace_id ! attribute data space identifier + INTEGER(HID_T) :: atype_id ! attribute data type identifier + + + INTEGER, DIMENSION(1) :: dset_data = 0 ! Data value + + INTEGER(HSIZE_T), DIMENSION(1) :: dims = 1 ! Datasets dimensions + INTEGER(HSIZE_T), DIMENSION(1) :: adims = 1 ! Attribute dimensions + + INTEGER, DIMENSION(1) :: attr_data = 12 + INTEGER :: rank = 1 ! Datasets rank + INTEGER :: arank = 1 ! Attribute rank + + INTEGER :: type !object identifier + INTEGER :: error ! Error flag + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + CHARACTER(LEN=80) name_buf + CHARACTER(LEN=280) name_buf1 + INTEGER(SIZE_T) buf_size + INTEGER(SIZE_T) name_size + INTEGER :: ref_count ! Reference count for IDs + + + INTEGER(hid_t) :: dtype ! datatype id + LOGICAL :: tri_ret ! value + + ! + ! Tests the function H5Iis_valid_f + ! + ! check that the ID is not valid + dtype = -1 + CALL H5Iis_valid_f(dtype, tri_ret, error) + CALL check("H5Iis_valid_f", error, total_error) + CALL verify("H5Iis_valid_f", tri_ret, .FALSE., total_error) + + ! Create a datatype id + CALL H5Tcopy_f(H5T_NATIVE_INTEGER,dtype,error) + CALL check("H5Tcopy_f", error, total_error) + + ! Check that the ID is valid + CALL H5Iis_valid_f(dtype, tri_ret, error) + CALL check("H5Iis_valid_f", error, total_error) + CALL verify("H5Tequal_f", tri_ret, .TRUE., total_error) + + CALL H5Tclose_f(dtype, error) + CALL check("H5Tclose_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" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + ! + ! Create a group named "/MyGroup" in the file. + ! + CALL h5gcreate_f(file_id, groupname, group_id, error) + CALL check("h5gcreate_f",error,total_error) + + ! + !Create data space for the dataset. + ! + CALL h5screate_simple_f(rank, dims, dspace_id, error) + CALL check("h5screate_simple_f",error,total_error) + + ! + ! create dataset in the file. + ! + CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f",error,total_error) + ! + ! Get dataset name from dataset identifier + ! + buf_size = 80 + CALL h5iget_name_f(dset_id, name_buf, buf_size, name_size, error) + CALL check("h5iget_name_f",error,total_error) + if (name_size .ne. len(dsetname)) then + write(*,*) "h5iget_name returned wrong name size" + total_error = total_error + 1 + else + if (name_buf(1:name_size) .ne. dsetname) then + write(*,*) "h5iget_name returned wrong name" + total_error = total_error + 1 + endif + endif + + ! + ! Get file identifier from dataset identifier and then get file name + ! + CALL h5iget_file_id_f(dset_id, new_file_id, error) + CALL check("h5iget_file_id_f",error,total_error) + name_size = 280 + CALL h5fget_name_f(new_file_id, name_buf1, name_size, error) + CALL check("h5fget_name_f",error,total_error) + if (name_buf1(1:name_size) .ne. fix_filename(1:name_size)) then + write(*,*) "h5fget_name returned wrong file name" + total_error = total_error + 1 + endif + + ! + ! Write data_in to the dataset + ! + data_dims(1) = 1 + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + + ! + ! Create scalar data space for dataset attribute. + ! + CALL h5screate_simple_f(arank, adims, aspace_id, error) + CALL check("h5screate_simple_f",error,total_error) + + ! + ! Create datatype for the Integer attribute. + ! + CALL h5tcopy_f(H5T_NATIVE_INTEGER, atype_id, error) + CALL check("h5tcopy_f",error,total_error) + + ! + ! Create dataset INTEGER attribute. + ! + CALL h5acreate_f(dset_id, aname, atype_id, aspace_id, attr_id, error) + CALL check("h5acreate_f",error,total_error) + + ! + ! Write the Integer attribute data. + ! + CALL h5awrite_f(attr_id, atype_id, attr_data, data_dims, error) + CALL check("h5awrite_f",error,total_error) + + ! + !Get the file identifier + ! + CALL h5iget_type_f(file_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get file identifier wrong",type,H5I_FILE_F,total_error) + + ! + !Get the group identifier + ! + CALL h5iget_type_f(group_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get group identifier wrong",type,H5I_GROUP_F,total_error) + + ! + !Get the datatype identifier + ! + CALL h5iget_type_f(atype_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get datatype identifier wrong",type,H5I_DATATYPE_F,total_error) + + ! + !Get the dataspace identifier + ! + CALL h5iget_type_f(aspace_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get dataspace identifier wrong",type,H5I_DATASPACE_F,total_error) + + ! + !Get the dataset identifier + ! + CALL h5iget_type_f(dset_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get dataset identifier wrong",type,H5I_DATASET_F,total_error) + + ! + !Get the attribute identifier + ! + CALL h5iget_type_f(attr_id, type, error) + CALL check("h5iget_type_f",error,total_error) + CALL verify("get attribute identifier wrong",type,H5I_ATTR_F,total_error) + + ! + ! Close the attribute. + ! + CALL h5aclose_f(attr_id, error) + CALL check("h5aclose_f",error,total_error) + ! + ! Close the dataspace. + ! + CALL h5sclose_f(aspace_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(dspace_id, error) + CALL check("h5sclose_f",error,total_error) + ! + ! Close the dataype. + ! + CALL h5tclose_f(atype_id, error) + CALL check("h5tclose_f",error,total_error) + + ! + ! Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + + ! + ! Close the group. + ! + CALL h5gclose_f(group_id, error) + CALL check("h5gclose_f",error,total_error) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + CALL h5fclose_f(new_file_id, error) + CALL check("h5fclose_f",error,total_error) + + ! + ! Basic Test of increment/decrement ID functions + ! + + ! Create a file + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + ! Get the reference count for the file ID + CALL h5iget_ref_f(file_id, ref_count, error) + CALL check("h5iget_ref_f",error,total_error) + CALL verify("get file ref count wrong",ref_count,1,total_error) + + ! Increment the reference count for the file ID + CALL h5iinc_ref_f(file_id, ref_count, error) + CALL check("h5iinc_ref_f",error,total_error) + CALL verify("get file ref count wrong",ref_count,2,total_error) + + ! Close the file normally. + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + + ! Get the reference count for the file ID + CALL h5iget_ref_f(file_id, ref_count, error) + CALL check("h5iget_ref_f",error,total_error) + CALL verify("get file ref count wrong",ref_count,1,total_error) + + ! Close the file by decrementing the reference count + CALL h5idec_ref_f(file_id, ref_count, error) + CALL check("h5idec_ref_f",error,total_error) + CALL verify("get file ref count wrong",ref_count,0,total_error) + ! Try closing the file again (should fail) + CALL h5eset_auto_f(0, error) + CALL h5fclose_f(file_id, error) + CALL verify("file close should fail",error,-1,total_error) + ! Clear the error stack from the file close failure + CALL h5eset_auto_f(1, error) + CALL h5eclear_f(error) + + if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + RETURN + END SUBROUTINE identifier_test + +END MODULE TH5I diff --git a/fortran/test/tH5I.f90 b/fortran/test/tH5I.f90 deleted file mode 100644 index 97c48c6..0000000 --- a/fortran/test/tH5I.f90 +++ /dev/null @@ -1,321 +0,0 @@ -!****h* root/fortran/test/tH5I.f90 -! -! NAME -! tH5I.f90 -! -! FUNCTION -! Basic testing of Fortran H5I APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! identifier_test -! -!***** -MODULE TH5I - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - - SUBROUTINE identifier_test(cleanup, total_error) - -! This subroutine tests following functionalities: h5iget_type_f - - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=6), PARAMETER :: filename = "itestf" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=10), PARAMETER :: dsetname = "/itestdset" ! Dataset name - CHARACTER(LEN=10), PARAMETER :: groupname = "itestgroup"! group name - CHARACTER(LEN=10), PARAMETER :: aname = "itestattr"! group name - - - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: new_file_id ! File identifier - INTEGER(HID_T) :: group_id ! group identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dspace_id ! Dataspace identifier - INTEGER(HID_T) :: attr_id ! Datatype attribute identifier - INTEGER(HID_T) :: aspace_id ! attribute data space identifier - INTEGER(HID_T) :: atype_id ! attribute data type identifier - - - INTEGER, DIMENSION(1) :: dset_data = 0 ! Data value - - INTEGER(HSIZE_T), DIMENSION(1) :: dims = 1 ! Datasets dimensions - INTEGER(HSIZE_T), DIMENSION(1) :: adims = 1 ! Attribute dimensions - - INTEGER, DIMENSION(1) :: attr_data = 12 - INTEGER :: rank = 1 ! Datasets rank - INTEGER :: arank = 1 ! Attribute rank - - INTEGER :: type !object identifier - INTEGER :: error ! Error flag - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - CHARACTER(LEN=80) name_buf - CHARACTER(LEN=280) name_buf1 - INTEGER(SIZE_T) buf_size - INTEGER(SIZE_T) name_size - INTEGER :: ref_count ! Reference count for IDs - - - INTEGER(hid_t) :: dtype ! datatype id - LOGICAL :: tri_ret ! value - - ! - ! Tests the function H5Iis_valid_f - ! - ! check that the ID is not valid - dtype = -1 - CALL H5Iis_valid_f(dtype, tri_ret, error) - CALL check("H5Iis_valid_f", error, total_error) - CALL verify("H5Iis_valid_f", tri_ret, .FALSE., total_error) - - ! Create a datatype id - CALL H5Tcopy_f(H5T_NATIVE_INTEGER,dtype,error) - CALL check("H5Tcopy_f", error, total_error) - - ! Check that the ID is valid - CALL H5Iis_valid_f(dtype, tri_ret, error) - CALL check("H5Iis_valid_f", error, total_error) - CALL verify("H5Tequal_f", tri_ret, .TRUE., total_error) - - CALL H5Tclose_f(dtype, error) - CALL check("H5Tclose_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" - stop - endif - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - ! - ! Create a group named "/MyGroup" in the file. - ! - CALL h5gcreate_f(file_id, groupname, group_id, error) - CALL check("h5gcreate_f",error,total_error) - - ! - !Create data space for the dataset. - ! - CALL h5screate_simple_f(rank, dims, dspace_id, error) - CALL check("h5screate_simple_f",error,total_error) - - ! - ! create dataset in the file. - ! - CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f",error,total_error) - ! - ! Get dataset name from dataset identifier - ! - buf_size = 80 - CALL h5iget_name_f(dset_id, name_buf, buf_size, name_size, error) - CALL check("h5iget_name_f",error,total_error) - if (name_size .ne. len(dsetname)) then - write(*,*) "h5iget_name returned wrong name size" - total_error = total_error + 1 - else - if (name_buf(1:name_size) .ne. dsetname) then - write(*,*) "h5iget_name returned wrong name" - total_error = total_error + 1 - endif - endif - - ! - ! Get file identifier from dataset identifier and then get file name - ! - CALL h5iget_file_id_f(dset_id, new_file_id, error) - CALL check("h5iget_file_id_f",error,total_error) - name_size = 280 - CALL h5fget_name_f(new_file_id, name_buf1, name_size, error) - CALL check("h5fget_name_f",error,total_error) - if (name_buf1(1:name_size) .ne. fix_filename(1:name_size)) then - write(*,*) "h5fget_name returned wrong file name" - total_error = total_error + 1 - endif - - ! - ! Write data_in to the dataset - ! - data_dims(1) = 1 - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - - ! - ! Create scalar data space for dataset attribute. - ! - CALL h5screate_simple_f(arank, adims, aspace_id, error) - CALL check("h5screate_simple_f",error,total_error) - - ! - ! Create datatype for the Integer attribute. - ! - CALL h5tcopy_f(H5T_NATIVE_INTEGER, atype_id, error) - CALL check("h5tcopy_f",error,total_error) - - ! - ! Create dataset INTEGER attribute. - ! - CALL h5acreate_f(dset_id, aname, atype_id, aspace_id, attr_id, error) - CALL check("h5acreate_f",error,total_error) - - ! - ! Write the Integer attribute data. - ! - CALL h5awrite_f(attr_id, atype_id, attr_data, data_dims, error) - CALL check("h5awrite_f",error,total_error) - - ! - !Get the file identifier - ! - CALL h5iget_type_f(file_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get file identifier wrong",type,H5I_FILE_F,total_error) - - ! - !Get the group identifier - ! - CALL h5iget_type_f(group_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get group identifier wrong",type,H5I_GROUP_F,total_error) - - ! - !Get the datatype identifier - ! - CALL h5iget_type_f(atype_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get datatype identifier wrong",type,H5I_DATATYPE_F,total_error) - - ! - !Get the dataspace identifier - ! - CALL h5iget_type_f(aspace_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get dataspace identifier wrong",type,H5I_DATASPACE_F,total_error) - - ! - !Get the dataset identifier - ! - CALL h5iget_type_f(dset_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get dataset identifier wrong",type,H5I_DATASET_F,total_error) - - ! - !Get the attribute identifier - ! - CALL h5iget_type_f(attr_id, type, error) - CALL check("h5iget_type_f",error,total_error) - CALL verify("get attribute identifier wrong",type,H5I_ATTR_F,total_error) - - ! - ! Close the attribute. - ! - CALL h5aclose_f(attr_id, error) - CALL check("h5aclose_f",error,total_error) - ! - ! Close the dataspace. - ! - CALL h5sclose_f(aspace_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(dspace_id, error) - CALL check("h5sclose_f",error,total_error) - ! - ! Close the dataype. - ! - CALL h5tclose_f(atype_id, error) - CALL check("h5tclose_f",error,total_error) - - ! - ! Close the dataset. - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - - ! - ! Close the group. - ! - CALL h5gclose_f(group_id, error) - CALL check("h5gclose_f",error,total_error) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - CALL h5fclose_f(new_file_id, error) - CALL check("h5fclose_f",error,total_error) - - ! - ! Basic Test of increment/decrement ID functions - ! - - ! Create a file - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - ! Get the reference count for the file ID - CALL h5iget_ref_f(file_id, ref_count, error) - CALL check("h5iget_ref_f",error,total_error) - CALL verify("get file ref count wrong",ref_count,1,total_error) - - ! Increment the reference count for the file ID - CALL h5iinc_ref_f(file_id, ref_count, error) - CALL check("h5iinc_ref_f",error,total_error) - CALL verify("get file ref count wrong",ref_count,2,total_error) - - ! Close the file normally. - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - - ! Get the reference count for the file ID - CALL h5iget_ref_f(file_id, ref_count, error) - CALL check("h5iget_ref_f",error,total_error) - CALL verify("get file ref count wrong",ref_count,1,total_error) - - ! Close the file by decrementing the reference count - CALL h5idec_ref_f(file_id, ref_count, error) - CALL check("h5idec_ref_f",error,total_error) - CALL verify("get file ref count wrong",ref_count,0,total_error) - ! Try closing the file again (should fail) - CALL h5eset_auto_f(0, error) - CALL h5fclose_f(file_id, error) - CALL verify("file close should fail",error,-1,total_error) - ! Clear the error stack from the file close failure - CALL h5eset_auto_f(1, error) - CALL h5eclear_f(error) - - if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - RETURN - END SUBROUTINE identifier_test - -END MODULE TH5I diff --git a/fortran/test/tH5L_F03.F90 b/fortran/test/tH5L_F03.F90 new file mode 100644 index 0000000..40afdbc --- /dev/null +++ b/fortran/test/tH5L_F03.F90 @@ -0,0 +1,318 @@ +!****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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. 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 diff --git a/fortran/test/tH5L_F03.f90 b/fortran/test/tH5L_F03.f90 deleted file mode 100644 index 40afdbc..0000000 --- a/fortran/test/tH5L_F03.f90 +++ /dev/null @@ -1,318 +0,0 @@ -!****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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. 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 diff --git a/fortran/test/tH5MISC_1_8.F90 b/fortran/test/tH5MISC_1_8.F90 new file mode 100644 index 0000000..ba3f095 --- /dev/null +++ b/fortran/test/tH5MISC_1_8.F90 @@ -0,0 +1,469 @@ +!****h* root/fortran/test/tH5MISC_1_8.f90 +! +! NAME +! tH5MISC_1_8.f90 +! +! FUNCTION +! Basic testing of Fortran API's introduced in 1.8 release. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** +MODULE TH5MISC_1_8 + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +SUBROUTINE dtransform(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: dxpl_id_c_to_f + INTEGER(HID_T) :: file_id + + CHARACTER(LEN=15), PARAMETER :: c_to_f = "(9/5.0)*x + 123" + INTEGER :: error + CHARACTER(LEN=15) :: ptrgetTest + CHARACTER(LEN=7) :: ptrgetTest_small + CHARACTER(LEN=30) :: ptrgetTest_big + + INTEGER(SIZE_T) :: size + + CALL H5Fcreate_f("dtransform.h5", H5F_ACC_TRUNC_F, file_id, error) + CALL check("dtransform.H5Fcreate_f", error, total_error) + + CALL H5Pcreate_f(H5P_DATASET_XFER_F, dxpl_id_c_to_f, error) + CALL check("dtransform.H5Pcreate_f", error, total_error) + + CALL H5Pset_data_transform_f(dxpl_id_c_to_f, c_to_f, error) + CALL check("dtransform.H5Pset_data_transform_f", error, total_error) + + CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest, error, size=size) + CALL check("dtransform.H5Pget_data_transform_f", error, total_error) + CALL verify("dtransform.H5Pget_data_transform_f", c_to_f, ptrgetTest, total_error) + CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error) + +! check case when receiving buffer to small + + CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_small, error, size=size) + CALL check("dtransform.H5Pget_data_transform_f", error, total_error) + CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:7), ptrgetTest_small, total_error) + CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error) + +! check case when receiving buffer to big + + CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_big, error, size=size) + CALL check("dtransform.H5Pget_data_transform_f", error, total_error) + CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:15), ptrgetTest_big(1:15), total_error) + CALL verify("dtransform.H5Pget_data_transform_f", INT(size), 15, total_error) + + CALL H5Fclose_f(file_id, error) + CALL check("H5Fclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f("dtransform", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + +END SUBROUTINE dtransform + + +!*************************************************************** +!** +!** test_genprop_basic_class(): Test basic generic property list code. +!** Tests creating new generic classes. +!** +!*************************************************************** + +SUBROUTINE test_genprop_basic_class(total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: cid1 ! Generic Property class ID + INTEGER(HID_T) :: cid2 ! Generic Property class ID + + CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1" + CHARACTER(LEN=7) :: name ! Name of class + CHARACTER(LEN=10) :: name_big ! Name of class bigger buffer + CHARACTER(LEN=4) :: name_small ! Name of class smaller buffer + INTEGER :: error + INTEGER :: size + LOGICAL :: flag + + ! Output message about test being performed + + !WRITE(*,*) "Testing Basic Generic Property List Class Creation Functionality" + + ! Try some bogus value for class identifier; function should fail gracefully + + cid1 = 456 + CALL H5Pget_class_name_f(cid1, name, size, error) + CALL verify("H5Pget_class_name", error, -1, error) + + ! Create a new generic class, derived from the root of the class hierarchy + CALL H5Pcreate_class_f(H5P_ROOT_F, CLASS1_NAME, cid1, error) + CALL check("H5Pcreate_class", error, total_error) + + ! Check class name + CALL H5Pget_class_name_f(cid1, name, size, error) + CALL check("H5Pget_class_name", error, total_error) + CALL verify("H5Pget_class_name", size,7,error) + CALL verify("H5Pget_class_name", name, CLASS1_NAME, error) + IF(error.NE.0)THEN + WRITE(*,*) 'Class names do not match! name=',name, 'CLASS1_NAME=',CLASS1_NAME + total_error = total_error + 1 + ENDIF + + ! Check class name smaller buffer + CALL H5Pget_class_name_f(cid1, name_small, size, error) + CALL check("H5Pget_class_name", error, total_error) + CALL verify("H5Pget_class_name", size,7,error) + CALL verify("H5Pget_class_name", name_small(1:4), CLASS1_NAME(1:4), error) + IF(error.NE.0)THEN + WRITE(*,*) 'Class names do not match! name=',name_small(1:4), 'CLASS1_NAME=',CLASS1_NAME(1:4) + total_error = total_error + 1 + ENDIF + + ! Check class name bigger buffer + CALL H5Pget_class_name_f(cid1, name_big, size, error) + CALL check("H5Pget_class_name", error, total_error) + CALL verify("H5Pget_class_name", size,7,error) + CALL verify("H5Pget_class_name", TRIM(name_big), TRIM(CLASS1_NAME), error) + IF(error.NE.0)THEN + WRITE(*,*) 'Class names do not match! name=',TRIM(name_small), 'CLASS1_NAME=',TRIM(CLASS1_NAME) + total_error = total_error + 1 + ENDIF + + ! Check class parent + CALL H5Pget_class_parent_f(cid1, cid2, error) + CALL check("H5Pget_class_parent_f", error, total_error) + + ! Verify class parent correct + CALL H5Pequal_f(cid2, H5P_ROOT_F, flag, error) + CALL check("H5Pequal_f", error, total_error) + CALL verify("H5Pequal_f", flag, .TRUE., total_error) + + + ! Make certain false postives aren't being returned + CALL H5Pequal_f(cid2, H5P_FILE_CREATE_F, flag, error) + CALL check("H5Pequal_f", error, total_error) + CALL verify("H5Pequal_f", flag, .FALSE., total_error) + + ! Close parent class + CALL H5Pclose_class_f(cid2, error) + CALL check("H5Pclose_class_f", error, total_error) + + + ! Close class + CALL H5Pclose_class_f(cid1, error) + CALL check("H5Pclose_class_f", error, total_error) + +END SUBROUTINE test_genprop_basic_class + +SUBROUTINE test_h5s_encode(total_error) + +!*************************************************************** +!** +!** test_h5s_encode(): Test H5S (dataspace) encoding and decoding. +!** +!*************************************************************** + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(hid_t) :: sid1, sid3! Dataspace ID + INTEGER(hid_t) :: decoded_sid1, decoded_sid3 + INTEGER :: rank ! LOGICAL rank of dataspace + INTEGER(size_t) :: sbuf_size=0, scalar_size=0 + +! Make sure the size is large + CHARACTER(LEN=288) :: sbuf + CHARACTER(LEN=288) :: scalar_buf + + INTEGER(hsize_t) :: n ! Number of dataspace elements + + INTEGER(hsize_t), DIMENSION(1:3) :: start = (/0, 0, 0/) + INTEGER(hsize_t), DIMENSION(1:3) :: stride = (/2, 5, 3/) + INTEGER(hsize_t), DIMENSION(1:3) :: count = (/2, 2, 2/) + INTEGER(hsize_t), DIMENSION(1:3) :: BLOCK = (/1, 3, 1/) + + INTEGER :: space_type + ! + ! Dataset dimensions + ! + INTEGER, PARAMETER :: SPACE1_DIM1= 3, SPACE1_DIM2=15, SPACE1_DIM3=13 + + INTEGER(HSIZE_T), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/) + INTEGER :: SPACE1_RANK = 3 + INTEGER :: error + + !------------------------------------------------------------------------- + ! * Test encoding and decoding of simple dataspace and hyperslab selection. + ! *------------------------------------------------------------------------- + ! + + CALL H5Screate_simple_f(SPACE1_RANK, dims1, sid1, error) + CALL check("H5Screate_simple", error, total_error) + + CALL h5sselect_hyperslab_f(sid1, H5S_SELECT_SET_F, & + start, count, error, stride=stride, BLOCK=BLOCK) + CALL check("h5sselect_hyperslab_f", error, total_error) + + + ! Encode simple data space in a buffer + + ! First find the buffer size + CALL H5Sencode_f(sid1, sbuf, sbuf_size, error) + CALL check("H5Sencode", error, total_error) + + + ! Try decoding bogus buffer + + CALL H5Sdecode_f(sbuf, decoded_sid1, error) + CALL verify("H5Sdecode", error, -1, total_error) + + CALL H5Sencode_f(sid1, sbuf, sbuf_size, error) + CALL check("H5Sencode", error, total_error) + + ! Decode from the dataspace buffer and return an object handle + CALL H5Sdecode_f(sbuf, decoded_sid1, error) + CALL check("H5Sdecode", error, total_error) + + + ! Verify the decoded dataspace + CALL h5sget_simple_extent_npoints_f(decoded_sid1, n, error) + CALL check("h5sget_simple_extent_npoints_f", error, total_error) + CALL verify("h5sget_simple_extent_npoints_f", INT(n), INT(SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3), & + total_error) + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(sid1, error) + CALL check("h5sclose_f", error, total_error) + + CALL h5sclose_f(decoded_sid1, error) + CALL check("h5sclose_f", error, total_error) + + ! ------------------------------------------------------------------------- + ! * Test encoding and decoding of scalar dataspace. + ! *------------------------------------------------------------------------- + ! + ! Create scalar dataspace + + CALL H5Screate_f(H5S_SCALAR_F, sid3, error) + CALL check("H5Screate_f",error, total_error) + + ! Encode scalar data space in a buffer + + ! First find the buffer size + CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error) + CALL check("H5Sencode_f", error, total_error) + + ! encode + + CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error) + CALL check("H5Sencode_f", error, total_error) + + + ! Decode from the dataspace buffer and return an object handle + + CALL H5Sdecode_f(scalar_buf, decoded_sid3, error) + CALL check("H5Sdecode_f", error, total_error) + + + ! Verify extent type + + CALL H5Sget_simple_extent_type_f(decoded_sid3, space_type, error) + CALL check("H5Sget_simple_extent_type_f", error, total_error) + CALL verify("H5Sget_simple_extent_type_f", space_type, H5S_SCALAR_F, total_error) + + ! Verify decoded dataspace + CALL h5sget_simple_extent_npoints_f(decoded_sid3, n, error) + CALL check("h5sget_simple_extent_npoints_f", error, total_error) + CALL verify("h5sget_simple_extent_npoints_f", INT(n), 1, total_error) + + CALL H5Sget_simple_extent_ndims_f(decoded_sid3, rank, error) + CALL CHECK("H5Sget_simple_extent_ndims_f", error, total_error) + CALL verify("H5Sget_simple_extent_ndims_f", rank, 0, total_error ) + + CALL h5sclose_f(sid3, error) + CALL check("h5sclose_f", error, total_error) + + CALL h5sclose_f(decoded_sid3, error) + CALL check("h5sclose_f", error, total_error) + +END SUBROUTINE test_h5s_encode + +!------------------------------------------------------------------------- +! Function: test_scaleoffset +! +! Purpose: Tests the integer datatype for scaleoffset filter +! with fill value set +! +! Return: Success: 0 +! Failure: >0 +! +! Programmer: M. Scot Breitenfeld +! Decemeber 11, 2010 +! +! Modifications: +! +!------------------------------------------------------------------------- +! + +SUBROUTINE test_scaleoffset(cleanup, total_error ) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + INTEGER(hid_t) :: file + + INTEGER(hid_t) :: dataset, datatype, space, mspace, dc + INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2, 5/) + INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2, 5/) + INTEGER, DIMENSION(1:2,1:5) :: orig_data + INTEGER, DIMENSION(1:2,1:5) :: new_data + INTEGER(hsize_t), DIMENSION(1:2) :: start ! Start of hyperslab + INTEGER(hsize_t), DIMENSION(1:2) :: stride ! Stride of hyperslab + INTEGER(hsize_t), DIMENSION(1:2) :: count ! BLOCK count + INTEGER(hsize_t), DIMENSION(1:2) :: BLOCK ! BLOCK sizes + INTEGER :: fillval + INTEGER(size_t) :: j + REAL :: x + INTEGER :: error + LOGICAL :: status + + ! check to see if filter is available + CALL H5Zfilter_avail_f(H5Z_FILTER_SCALEOFFSET_F, status, error) + IF(.NOT.status)THEN ! We don't have H5Z_FILTER_SCALEOFFSET_F filter + total_error = -1 ! so return + RETURN + ENDIF + + CALL H5Fcreate_f("h5scaleoffset.h5", H5F_ACC_TRUNC_F, file, error) + CALL check("H5Fcreate_f", error, total_error) + + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error) + CALL CHECK(" H5Tcopy_f", error, total_error) + + ! Set order of dataset datatype + CALL H5Tset_order_f(datatype, H5T_ORDER_BE_F, error) + CALL CHECK(" H5Tset_order_f", error, total_error) + + ! Create the data space for the dataset + CALL H5Screate_simple_f(2, dims, space, error) + CALL CHECK(" H5Screate_simple_f", error, total_error) + + ! Create the dataset property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error) + CALL CHECK(" H5Pcreate_f", error, total_error) + + ! Set fill value + fillval = 10000 + CALL H5Pset_fill_value_f(dc, H5T_NATIVE_INTEGER, fillval, error) + CALL CHECK(" H5Pset_fill_value_f", error, total_error) + + ! Set up to use scaleoffset filter, let library calculate minbits + CALL H5Pset_chunk_f(dc, 2, chunk_dim, error) + CALL CHECK(" H5Pset_chunk_f", error, total_error) + + CALL H5Pset_scaleoffset_f(dc, H5Z_SO_INT_F, H5Z_SO_INT_MINBITS_DEFAULT_F, error) + CALL CHECK(" H5Pset_scaleoffset_f", error, total_error) + + ! Create the dataset + CALL H5Dcreate_f(file, "scaleoffset_int", datatype, & + space, dataset, error, dc) + CALL CHECK(" H5Dcreate_f", error, total_error) + + ! Create the memory data space + CALL H5Screate_simple_f(2, dims, mspace, error) + CALL CHECK(" H5Screate_simple_f", error, total_error) + + ! Select hyperslab for data to write, using 1x5 blocks, + ! (1,1) stride and (1,1) count starting at the position (0,0) + + start(1:2) = (/0,0/) + stride(1:2) = (/1,1/) + COUNT(1:2) = (/1,1/) + BLOCK(1:2) = (/1,5/) + + CALL H5Sselect_hyperslab_f(mspace, H5S_SELECT_SET_F, start, & + count, error, stride, BLOCK) + CALL CHECK(" H5Sselect_hyperslab_f", error, total_error) + + CALL RANDOM_SEED() + ! Initialize data of hyperslab + DO j = 1, INT(dims(2)) + CALL RANDOM_NUMBER(x) + orig_data(1,j) = INT(x*10000.) + IF(MOD(j,2_size_t).EQ.0)THEN + orig_data(1,j) = - orig_data(1,j) + ENDIF + ENDDO + + !---------------------------------------------------------------------- + ! STEP 1: Test scaleoffset by setting up a chunked dataset and writing + ! to it. + !---------------------------------------------------------------------- + + ! Only data in the hyperslab will be written, other value should be fill value + CALL H5Dwrite_f(dataset, H5T_NATIVE_INTEGER, orig_data, dims, error, mspace, mspace, H5P_DEFAULT_F) + CALL CHECK(" H5Dwrite_f", error, total_error) + + !---------------------------------------------------------------------- + ! STEP 2: Try to read the data we just wrote. + !---------------------------------------------------------------------- + + ! Read the dataset back + + CALL H5Dread_f(dataset, H5T_NATIVE_INTEGER, new_data, dims, error, mspace, mspace, H5P_DEFAULT_F) + CALL CHECK(" H5Dread_f", error, total_error) + + ! Check that the values read are the same as the values written + DO j = 1, INT(dims(2)) + IF(new_data(1,j) .NE. orig_data(1,j))THEN + total_error = total_error + 1 + WRITE(*,'(" Read different values than written.")') + WRITE(*,'(" At index ", 2(1X,I0))') 1, j + EXIT + ENDIF + ENDDO + !---------------------------------------------------------------------- + ! Cleanup + !---------------------------------------------------------------------- + CALL H5Tclose_f(datatype, error) + CALL CHECK(" H5Tclose_f", error, total_error) + CALL H5Pclose_f(dc, error) + CALL CHECK(" H5Pclose_f", error, total_error) + CALL H5Sclose_f(space, error) + CALL CHECK(" H5Sclose_f", error, total_error) + CALL H5Dclose_f(dataset, error) + CALL CHECK(" H5Dclose_f", error, total_error) + CALL H5Fclose_f(file, error) + CALL CHECK(" H5Fclose_f", error, total_error) + + IF(cleanup) CALL h5_cleanup_f("h5scaleoffset", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + +END SUBROUTINE test_scaleoffset + +END MODULE TH5MISC_1_8 diff --git a/fortran/test/tH5MISC_1_8.f90 b/fortran/test/tH5MISC_1_8.f90 deleted file mode 100644 index ba3f095..0000000 --- a/fortran/test/tH5MISC_1_8.f90 +++ /dev/null @@ -1,469 +0,0 @@ -!****h* root/fortran/test/tH5MISC_1_8.f90 -! -! NAME -! tH5MISC_1_8.f90 -! -! FUNCTION -! Basic testing of Fortran API's introduced in 1.8 release. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** -MODULE TH5MISC_1_8 - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -SUBROUTINE dtransform(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(HID_T) :: dxpl_id_c_to_f - INTEGER(HID_T) :: file_id - - CHARACTER(LEN=15), PARAMETER :: c_to_f = "(9/5.0)*x + 123" - INTEGER :: error - CHARACTER(LEN=15) :: ptrgetTest - CHARACTER(LEN=7) :: ptrgetTest_small - CHARACTER(LEN=30) :: ptrgetTest_big - - INTEGER(SIZE_T) :: size - - CALL H5Fcreate_f("dtransform.h5", H5F_ACC_TRUNC_F, file_id, error) - CALL check("dtransform.H5Fcreate_f", error, total_error) - - CALL H5Pcreate_f(H5P_DATASET_XFER_F, dxpl_id_c_to_f, error) - CALL check("dtransform.H5Pcreate_f", error, total_error) - - CALL H5Pset_data_transform_f(dxpl_id_c_to_f, c_to_f, error) - CALL check("dtransform.H5Pset_data_transform_f", error, total_error) - - CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest, error, size=size) - CALL check("dtransform.H5Pget_data_transform_f", error, total_error) - CALL verify("dtransform.H5Pget_data_transform_f", c_to_f, ptrgetTest, total_error) - CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error) - -! check case when receiving buffer to small - - CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_small, error, size=size) - CALL check("dtransform.H5Pget_data_transform_f", error, total_error) - CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:7), ptrgetTest_small, total_error) - CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error) - -! check case when receiving buffer to big - - CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_big, error, size=size) - CALL check("dtransform.H5Pget_data_transform_f", error, total_error) - CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:15), ptrgetTest_big(1:15), total_error) - CALL verify("dtransform.H5Pget_data_transform_f", INT(size), 15, total_error) - - CALL H5Fclose_f(file_id, error) - CALL check("H5Fclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f("dtransform", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - -END SUBROUTINE dtransform - - -!*************************************************************** -!** -!** test_genprop_basic_class(): Test basic generic property list code. -!** Tests creating new generic classes. -!** -!*************************************************************** - -SUBROUTINE test_genprop_basic_class(total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(HID_T) :: cid1 ! Generic Property class ID - INTEGER(HID_T) :: cid2 ! Generic Property class ID - - CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1" - CHARACTER(LEN=7) :: name ! Name of class - CHARACTER(LEN=10) :: name_big ! Name of class bigger buffer - CHARACTER(LEN=4) :: name_small ! Name of class smaller buffer - INTEGER :: error - INTEGER :: size - LOGICAL :: flag - - ! Output message about test being performed - - !WRITE(*,*) "Testing Basic Generic Property List Class Creation Functionality" - - ! Try some bogus value for class identifier; function should fail gracefully - - cid1 = 456 - CALL H5Pget_class_name_f(cid1, name, size, error) - CALL verify("H5Pget_class_name", error, -1, error) - - ! Create a new generic class, derived from the root of the class hierarchy - CALL H5Pcreate_class_f(H5P_ROOT_F, CLASS1_NAME, cid1, error) - CALL check("H5Pcreate_class", error, total_error) - - ! Check class name - CALL H5Pget_class_name_f(cid1, name, size, error) - CALL check("H5Pget_class_name", error, total_error) - CALL verify("H5Pget_class_name", size,7,error) - CALL verify("H5Pget_class_name", name, CLASS1_NAME, error) - IF(error.NE.0)THEN - WRITE(*,*) 'Class names do not match! name=',name, 'CLASS1_NAME=',CLASS1_NAME - total_error = total_error + 1 - ENDIF - - ! Check class name smaller buffer - CALL H5Pget_class_name_f(cid1, name_small, size, error) - CALL check("H5Pget_class_name", error, total_error) - CALL verify("H5Pget_class_name", size,7,error) - CALL verify("H5Pget_class_name", name_small(1:4), CLASS1_NAME(1:4), error) - IF(error.NE.0)THEN - WRITE(*,*) 'Class names do not match! name=',name_small(1:4), 'CLASS1_NAME=',CLASS1_NAME(1:4) - total_error = total_error + 1 - ENDIF - - ! Check class name bigger buffer - CALL H5Pget_class_name_f(cid1, name_big, size, error) - CALL check("H5Pget_class_name", error, total_error) - CALL verify("H5Pget_class_name", size,7,error) - CALL verify("H5Pget_class_name", TRIM(name_big), TRIM(CLASS1_NAME), error) - IF(error.NE.0)THEN - WRITE(*,*) 'Class names do not match! name=',TRIM(name_small), 'CLASS1_NAME=',TRIM(CLASS1_NAME) - total_error = total_error + 1 - ENDIF - - ! Check class parent - CALL H5Pget_class_parent_f(cid1, cid2, error) - CALL check("H5Pget_class_parent_f", error, total_error) - - ! Verify class parent correct - CALL H5Pequal_f(cid2, H5P_ROOT_F, flag, error) - CALL check("H5Pequal_f", error, total_error) - CALL verify("H5Pequal_f", flag, .TRUE., total_error) - - - ! Make certain false postives aren't being returned - CALL H5Pequal_f(cid2, H5P_FILE_CREATE_F, flag, error) - CALL check("H5Pequal_f", error, total_error) - CALL verify("H5Pequal_f", flag, .FALSE., total_error) - - ! Close parent class - CALL H5Pclose_class_f(cid2, error) - CALL check("H5Pclose_class_f", error, total_error) - - - ! Close class - CALL H5Pclose_class_f(cid1, error) - CALL check("H5Pclose_class_f", error, total_error) - -END SUBROUTINE test_genprop_basic_class - -SUBROUTINE test_h5s_encode(total_error) - -!*************************************************************** -!** -!** test_h5s_encode(): Test H5S (dataspace) encoding and decoding. -!** -!*************************************************************** - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(hid_t) :: sid1, sid3! Dataspace ID - INTEGER(hid_t) :: decoded_sid1, decoded_sid3 - INTEGER :: rank ! LOGICAL rank of dataspace - INTEGER(size_t) :: sbuf_size=0, scalar_size=0 - -! Make sure the size is large - CHARACTER(LEN=288) :: sbuf - CHARACTER(LEN=288) :: scalar_buf - - INTEGER(hsize_t) :: n ! Number of dataspace elements - - INTEGER(hsize_t), DIMENSION(1:3) :: start = (/0, 0, 0/) - INTEGER(hsize_t), DIMENSION(1:3) :: stride = (/2, 5, 3/) - INTEGER(hsize_t), DIMENSION(1:3) :: count = (/2, 2, 2/) - INTEGER(hsize_t), DIMENSION(1:3) :: BLOCK = (/1, 3, 1/) - - INTEGER :: space_type - ! - ! Dataset dimensions - ! - INTEGER, PARAMETER :: SPACE1_DIM1= 3, SPACE1_DIM2=15, SPACE1_DIM3=13 - - INTEGER(HSIZE_T), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/) - INTEGER :: SPACE1_RANK = 3 - INTEGER :: error - - !------------------------------------------------------------------------- - ! * Test encoding and decoding of simple dataspace and hyperslab selection. - ! *------------------------------------------------------------------------- - ! - - CALL H5Screate_simple_f(SPACE1_RANK, dims1, sid1, error) - CALL check("H5Screate_simple", error, total_error) - - CALL h5sselect_hyperslab_f(sid1, H5S_SELECT_SET_F, & - start, count, error, stride=stride, BLOCK=BLOCK) - CALL check("h5sselect_hyperslab_f", error, total_error) - - - ! Encode simple data space in a buffer - - ! First find the buffer size - CALL H5Sencode_f(sid1, sbuf, sbuf_size, error) - CALL check("H5Sencode", error, total_error) - - - ! Try decoding bogus buffer - - CALL H5Sdecode_f(sbuf, decoded_sid1, error) - CALL verify("H5Sdecode", error, -1, total_error) - - CALL H5Sencode_f(sid1, sbuf, sbuf_size, error) - CALL check("H5Sencode", error, total_error) - - ! Decode from the dataspace buffer and return an object handle - CALL H5Sdecode_f(sbuf, decoded_sid1, error) - CALL check("H5Sdecode", error, total_error) - - - ! Verify the decoded dataspace - CALL h5sget_simple_extent_npoints_f(decoded_sid1, n, error) - CALL check("h5sget_simple_extent_npoints_f", error, total_error) - CALL verify("h5sget_simple_extent_npoints_f", INT(n), INT(SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3), & - total_error) - - ! - !Close the dataspace for the dataset. - ! - CALL h5sclose_f(sid1, error) - CALL check("h5sclose_f", error, total_error) - - CALL h5sclose_f(decoded_sid1, error) - CALL check("h5sclose_f", error, total_error) - - ! ------------------------------------------------------------------------- - ! * Test encoding and decoding of scalar dataspace. - ! *------------------------------------------------------------------------- - ! - ! Create scalar dataspace - - CALL H5Screate_f(H5S_SCALAR_F, sid3, error) - CALL check("H5Screate_f",error, total_error) - - ! Encode scalar data space in a buffer - - ! First find the buffer size - CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error) - CALL check("H5Sencode_f", error, total_error) - - ! encode - - CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error) - CALL check("H5Sencode_f", error, total_error) - - - ! Decode from the dataspace buffer and return an object handle - - CALL H5Sdecode_f(scalar_buf, decoded_sid3, error) - CALL check("H5Sdecode_f", error, total_error) - - - ! Verify extent type - - CALL H5Sget_simple_extent_type_f(decoded_sid3, space_type, error) - CALL check("H5Sget_simple_extent_type_f", error, total_error) - CALL verify("H5Sget_simple_extent_type_f", space_type, H5S_SCALAR_F, total_error) - - ! Verify decoded dataspace - CALL h5sget_simple_extent_npoints_f(decoded_sid3, n, error) - CALL check("h5sget_simple_extent_npoints_f", error, total_error) - CALL verify("h5sget_simple_extent_npoints_f", INT(n), 1, total_error) - - CALL H5Sget_simple_extent_ndims_f(decoded_sid3, rank, error) - CALL CHECK("H5Sget_simple_extent_ndims_f", error, total_error) - CALL verify("H5Sget_simple_extent_ndims_f", rank, 0, total_error ) - - CALL h5sclose_f(sid3, error) - CALL check("h5sclose_f", error, total_error) - - CALL h5sclose_f(decoded_sid3, error) - CALL check("h5sclose_f", error, total_error) - -END SUBROUTINE test_h5s_encode - -!------------------------------------------------------------------------- -! Function: test_scaleoffset -! -! Purpose: Tests the integer datatype for scaleoffset filter -! with fill value set -! -! Return: Success: 0 -! Failure: >0 -! -! Programmer: M. Scot Breitenfeld -! Decemeber 11, 2010 -! -! Modifications: -! -!------------------------------------------------------------------------- -! - -SUBROUTINE test_scaleoffset(cleanup, total_error ) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - INTEGER(hid_t) :: file - - INTEGER(hid_t) :: dataset, datatype, space, mspace, dc - INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2, 5/) - INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2, 5/) - INTEGER, DIMENSION(1:2,1:5) :: orig_data - INTEGER, DIMENSION(1:2,1:5) :: new_data - INTEGER(hsize_t), DIMENSION(1:2) :: start ! Start of hyperslab - INTEGER(hsize_t), DIMENSION(1:2) :: stride ! Stride of hyperslab - INTEGER(hsize_t), DIMENSION(1:2) :: count ! BLOCK count - INTEGER(hsize_t), DIMENSION(1:2) :: BLOCK ! BLOCK sizes - INTEGER :: fillval - INTEGER(size_t) :: j - REAL :: x - INTEGER :: error - LOGICAL :: status - - ! check to see if filter is available - CALL H5Zfilter_avail_f(H5Z_FILTER_SCALEOFFSET_F, status, error) - IF(.NOT.status)THEN ! We don't have H5Z_FILTER_SCALEOFFSET_F filter - total_error = -1 ! so return - RETURN - ENDIF - - CALL H5Fcreate_f("h5scaleoffset.h5", H5F_ACC_TRUNC_F, file, error) - CALL check("H5Fcreate_f", error, total_error) - - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error) - CALL CHECK(" H5Tcopy_f", error, total_error) - - ! Set order of dataset datatype - CALL H5Tset_order_f(datatype, H5T_ORDER_BE_F, error) - CALL CHECK(" H5Tset_order_f", error, total_error) - - ! Create the data space for the dataset - CALL H5Screate_simple_f(2, dims, space, error) - CALL CHECK(" H5Screate_simple_f", error, total_error) - - ! Create the dataset property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error) - CALL CHECK(" H5Pcreate_f", error, total_error) - - ! Set fill value - fillval = 10000 - CALL H5Pset_fill_value_f(dc, H5T_NATIVE_INTEGER, fillval, error) - CALL CHECK(" H5Pset_fill_value_f", error, total_error) - - ! Set up to use scaleoffset filter, let library calculate minbits - CALL H5Pset_chunk_f(dc, 2, chunk_dim, error) - CALL CHECK(" H5Pset_chunk_f", error, total_error) - - CALL H5Pset_scaleoffset_f(dc, H5Z_SO_INT_F, H5Z_SO_INT_MINBITS_DEFAULT_F, error) - CALL CHECK(" H5Pset_scaleoffset_f", error, total_error) - - ! Create the dataset - CALL H5Dcreate_f(file, "scaleoffset_int", datatype, & - space, dataset, error, dc) - CALL CHECK(" H5Dcreate_f", error, total_error) - - ! Create the memory data space - CALL H5Screate_simple_f(2, dims, mspace, error) - CALL CHECK(" H5Screate_simple_f", error, total_error) - - ! Select hyperslab for data to write, using 1x5 blocks, - ! (1,1) stride and (1,1) count starting at the position (0,0) - - start(1:2) = (/0,0/) - stride(1:2) = (/1,1/) - COUNT(1:2) = (/1,1/) - BLOCK(1:2) = (/1,5/) - - CALL H5Sselect_hyperslab_f(mspace, H5S_SELECT_SET_F, start, & - count, error, stride, BLOCK) - CALL CHECK(" H5Sselect_hyperslab_f", error, total_error) - - CALL RANDOM_SEED() - ! Initialize data of hyperslab - DO j = 1, INT(dims(2)) - CALL RANDOM_NUMBER(x) - orig_data(1,j) = INT(x*10000.) - IF(MOD(j,2_size_t).EQ.0)THEN - orig_data(1,j) = - orig_data(1,j) - ENDIF - ENDDO - - !---------------------------------------------------------------------- - ! STEP 1: Test scaleoffset by setting up a chunked dataset and writing - ! to it. - !---------------------------------------------------------------------- - - ! Only data in the hyperslab will be written, other value should be fill value - CALL H5Dwrite_f(dataset, H5T_NATIVE_INTEGER, orig_data, dims, error, mspace, mspace, H5P_DEFAULT_F) - CALL CHECK(" H5Dwrite_f", error, total_error) - - !---------------------------------------------------------------------- - ! STEP 2: Try to read the data we just wrote. - !---------------------------------------------------------------------- - - ! Read the dataset back - - CALL H5Dread_f(dataset, H5T_NATIVE_INTEGER, new_data, dims, error, mspace, mspace, H5P_DEFAULT_F) - CALL CHECK(" H5Dread_f", error, total_error) - - ! Check that the values read are the same as the values written - DO j = 1, INT(dims(2)) - IF(new_data(1,j) .NE. orig_data(1,j))THEN - total_error = total_error + 1 - WRITE(*,'(" Read different values than written.")') - WRITE(*,'(" At index ", 2(1X,I0))') 1, j - EXIT - ENDIF - ENDDO - !---------------------------------------------------------------------- - ! Cleanup - !---------------------------------------------------------------------- - CALL H5Tclose_f(datatype, error) - CALL CHECK(" H5Tclose_f", error, total_error) - CALL H5Pclose_f(dc, error) - CALL CHECK(" H5Pclose_f", error, total_error) - CALL H5Sclose_f(space, error) - CALL CHECK(" H5Sclose_f", error, total_error) - CALL H5Dclose_f(dataset, error) - CALL CHECK(" H5Dclose_f", error, total_error) - CALL H5Fclose_f(file, error) - CALL CHECK(" H5Fclose_f", error, total_error) - - IF(cleanup) CALL h5_cleanup_f("h5scaleoffset", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - -END SUBROUTINE test_scaleoffset - -END MODULE TH5MISC_1_8 diff --git a/fortran/test/tH5O.F90 b/fortran/test/tH5O.F90 new file mode 100644 index 0000000..51e1d64 --- /dev/null +++ b/fortran/test/tH5O.F90 @@ -0,0 +1,793 @@ +!****h* root/fortran/test/tH5O.f90 +! +! NAME +! tH5O.f90 +! +! FUNCTION +! Basic testing of Fortran H5O APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! test_h5o, test_h5o_link, test_h5o_plist +! +!***** +MODULE TH5O + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +SUBROUTINE test_h5o(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + INTEGER :: error + + CALL test_h5o_plist(total_error) ! Test object creation properties + CALL test_h5o_link(total_error) ! Test object link routine + + IF(cleanup) CALL h5_cleanup_f("TestFile", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f("test", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + +END SUBROUTINE test_h5o + +!*************************************************************** +!** +!** test_h5o_link: Test creating link to object +!** +!*************************************************************** + +SUBROUTINE test_h5o_link(total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: file_id + INTEGER(HID_T) :: group_id + INTEGER(HID_T) :: space_id + INTEGER(HID_T) :: dset_id + INTEGER(HID_T) :: type_id + INTEGER(HID_T) :: fapl_id + INTEGER(HID_T) :: lcpl_id + INTEGER(HID_T) :: ocpypl_id + CHARACTER(LEN=11), PARAMETER :: TEST_FILENAME = 'TestFile.h5' + INTEGER, PARAMETER :: TEST6_DIM1 = 2, TEST6_DIM2 = 5 +!EP INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/) + INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/TEST6_DIM1,TEST6_DIM2/) +!EP INTEGER, DIMENSION(1:TEST6_DIM1,1:TEST6_DIM2) :: wdata, rdata + INTEGER, DIMENSION(TEST6_DIM1,TEST6_DIM2) :: wdata, rdata + + INTEGER, PARAMETER :: TRUE = 1 + + LOGICAL :: committed ! Whether the named datatype is committed + + INTEGER :: i, j + INTEGER :: error ! Value returned from API calls + + CHARACTER(LEN=14) :: NAME_DATATYPE_SIMPLE="H5T_NATIVE_INT" + CHARACTER(LEN=16) :: NAME_DATATYPE_SIMPLE2="H5T_NATIVE_INT-2" + INTEGER(HID_T) :: tid, tid2 + LOGICAL :: flag + + ! Data for tested h5ocopy_f + CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1" + INTEGER , PARAMETER :: dim0 = 4 + + INTEGER(HSIZE_T), DIMENSION(1:1) :: dims2 = (/dim0/) ! size read/write buffer + INTEGER , DIMENSION(1:dim0) :: wdata2 ! Write buffer + LOGICAL :: link_exists + CHARACTER(LEN=8) :: chr_exact + CHARACTER(LEN=10) :: chr_lg + INTEGER(size_t) :: nlinks + INTEGER(HID_T) :: plist = -1 + + CHARACTER(LEN=20) :: dset_comment = "dataset comment" + CHARACTER(LEN=13) :: grp_comment = "group comment" + CHARACTER(LEN=10) :: comment_sm ! to small comment sized buffer + CHARACTER(LEN=15) :: comment ! exact comment sized buffer + CHARACTER(LEN=20) :: comment_lg ! large comment sized buffer + INTEGER(HSSIZE_T) :: comment_size + INTEGER(SIZE_T) :: comment_size2 + + ! Initialize the raw data + DO i = 1, TEST6_DIM1 + DO j = 1, TEST6_DIM2 + wdata(i,j) = i*j + ENDDO + ENDDO + + ! Create the dataspace + CALL h5screate_simple_f(2, dims, space_id, error) + CALL check("h5screate_simple_f",error,total_error) + + ! Create LCPL with intermediate group creation flag set + CALL H5Pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) + CALL check("h5Pcreate_f",error,total_error) + + CALL H5Pset_create_inter_group_f(lcpl_id, TRUE, error) + CALL check("H5Pset_create_inter_group_f",error,total_error) + + ! Loop over using new group format + ! for(new_format = FALSE; new_format <= TRUE; new_format++) { + + ! Make a FAPL that uses the "use the latest version of the format" bounds + CALL H5Pcreate_f(H5P_FILE_ACCESS_F,fapl_id,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_id, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) + CALL check("H5Pset_libver_bounds_f",error, total_error) + + ! Create a new HDF5 file + CALL H5Fcreate_f(TEST_FILENAME, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl_id) + CALL check("H5Fcreate_f", error, total_error) + + ! Close the FAPL + CALL h5pclose_f(fapl_id, error) + CALL check("h5pclose_f",error,total_error) + + ! Create and commit a datatype with no name + CALL H5Tcopy_f( H5T_NATIVE_INTEGER, type_id, error) + CALL check("H5Tcopy_F",error,total_error) + + CALL H5Tcommit_anon_f(file_id, type_id, error) ! using no optional parameters + CALL check("H5Tcommit_anon_F",error,total_error) + + CALL H5Tcommitted_f(type_id, committed, error) + CALL check("H5Tcommitted_f",error,total_error) + CALL verify("H5Tcommitted_f", committed, .TRUE., total_error) + + ! Create a dataset with no name using the committed datatype + CALL H5Dcreate_anon_f(file_id, type_id, space_id, dset_id, error ) ! using no optional parameters + CALL check("H5Dcreate_anon_f",error,total_error) + ! + ! Verify that we can write to and read from the dataset + ! + ! Write the data to the dataset + +!EP CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata, dims, error, & +!EP mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata, dims, error) + CALL check("h5dwrite_f", error, total_error) + + ! Read the data back +!EP CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, & +!EP mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) + CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error) + CALL check("h5dread_f", error, total_error) + + ! Verify the data + DO i = 1, TEST6_DIM1 + DO j = 1, TEST6_DIM2 + CALL verify("H5Dread_f",wdata(i,j),rdata(i,j),total_error) + wdata(i,j) = i*j + ENDDO + ENDDO + + ! Create a group with no name + + CALL H5Gcreate_anon_f(file_id, group_id, error) + CALL check("H5Gcreate_anon", error, total_error) + + ! Link nameless datatype into nameless group + CALL H5Olink_f(type_id, group_id, "datatype", error, H5P_DEFAULT_F) + CALL check("H5Olink_f", error, total_error) + + ! Link nameless dataset into nameless group with intermediate group + CALL H5Olink_f(dset_id, group_id, "inter_group/dataset", error, lcpl_id, H5P_DEFAULT_F) + CALL check("H5Olink_f", error, total_error) + + ! Close IDs for dataset and datatype + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f", error, total_error) + + ! Re-open datatype using new link + CALL H5Topen_f(group_id, "datatype", type_id, error) + CALL check("h5topen_f", error, total_error) + + ! Link nameless group to root group and close the group ID + CALL H5Olink_f(group_id, file_id, "/group", error) + CALL check("H5Olink_f", error, total_error) + + CALL h5gclose_f(group_id, error) + CALL check("h5gclose_f",error,total_error) + + ! Open dataset through root group and verify its data + CALL H5Dopen_f(file_id, "/group/inter_group/dataset", dset_id, error) + CALL check("test_lcpl.h5dopen_f", error, total_error) + + ! Read data from dataset +!EP CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, & +!EP H5S_ALL_F, H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) + CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error) + CALL check("h5dread_f", error, total_error) + + ! Verify the data + DO i = 1, TEST6_DIM1 + DO j = 1, TEST6_DIM2 + CALL verify("H5Dread",wdata(i,j),rdata(i,j),total_error) + ENDDO + ENDDO + ! Close open IDs + + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f",error,total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f",error,total_error) + + ! Close remaining IDs + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5pclose_f(lcpl_id,error) + CALL check("h5pclose_f", error, total_error) + + ! ********************* + ! CHECK H5OCOPY_F + ! ********************* + + DO i = 1, dim0 + wdata2(i) = i-1 + ENDDO + ! + ! Create dataspace. Setting size to be the current size. + ! + CALL h5screate_simple_f(1, dims2, space_id, error) + CALL check("h5screate_simple_f", error, total_error) + ! + ! Create intermediate groups + ! + CALL h5gcreate_f(file_id,"/G1",group_id,error) + CALL check("h5gcreate_f", error, total_error) + CALL h5gcreate_f(file_id,"/G1/G2",group_id,error) + CALL check("h5gcreate_f", error, total_error) + CALL h5gcreate_f(file_id,"/G1/G2/G3",group_id,error) + CALL check("h5gcreate_f", error, total_error) + + ! Try putting a comment on the group /G1/G2/G3 by name + CALL h5oset_comment_by_name_f(file_id, "/G1/G2/G3", grp_comment, error) + CALL check("h5oset_comment_by_name_f", error, total_error) + + comment_lg = ' ' + + CALL h5oget_comment_by_name_f(file_id, "/G1/G2/G3", comment_lg, error) + CALL check("h5oget_comment_by_name_f", error, total_error) + + IF(comment_lg(1:13).NE.grp_comment)THEN + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + IF(comment_lg(14:20).NE.' ')THEN ! make sure no NULL terminator + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + + ! Try putting a comment on the group /G1/G2/G3 by name with trailing blanks + + CALL h5oset_comment_by_name_f(file_id, "/G1/G2/G3"//' ', grp_comment, error) + CALL check("h5oset_comment_by_name_f", error, total_error) + + comment_lg = ' ' + + CALL h5oget_comment_by_name_f(file_id, "/G1/G2/G3"//' ', comment_lg, error) + CALL check("h5oget_comment_by_name_f", error, total_error) + + IF(comment_lg(1:13).NE.grp_comment)THEN + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + IF(comment_lg(14:20).NE.' ')THEN ! make sure no NULL terminator + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + + ! + ! Create the dataset + ! + CALL h5dcreate_f(group_id, dataset, H5T_STD_I32LE, space_id, dset_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! Putting a comment on the dataset + CALL h5oset_comment_f(dset_id, dset_comment, error) + CALL check("h5oset_comment_f", error, total_error) + + ! Try reading into a buffer that is the correct size + + CALL h5oget_comment_f(dset_id, comment, error) + CALL check("h5oget_comment_f", error, total_error) + + IF(comment(1:15).NE.dset_comment(1:15))THEN + CALL check("h5oget_comment_f", -1, total_error) + ENDIF + + ! Try reading into a buffer that is to small + + CALL h5oget_comment_f(dset_id, comment_sm, error) + CALL check("h5oget_comment_f", error, total_error) + + IF(comment_sm(1:10).NE.dset_comment(1:10))THEN + CALL check("h5oget_comment_f", -1, total_error) + ENDIF + + ! Try reading into a buffer that is larger then needed + + comment_lg = ' ' + + CALL h5oget_comment_f(dset_id, comment_lg, error) + CALL check("h5oget_comment_f", error, total_error) + + IF(comment_lg(1:15).NE.dset_comment)THEN + CALL check("h5oget_comment_f", -1, total_error) + ENDIF + IF(comment_lg(16:20).NE.' ')THEN ! make sure no NULL terminator + CALL check("h5oget_comment_f", -1, total_error) + ENDIF + ! + ! Check optional parameter + ! + CALL h5oget_comment_f(dset_id, comment_lg, error, comment_size) + CALL check("h5oget_comment_f", error, total_error) + + IF( comment_size.NE.15)THEN + CALL check("h5oget_comment_f", -1, total_error) + ENDIF + + ! CHECK h5oget_comment_by_name_f + + ! Try reading into a buffer that is the correct size + + CALL h5oget_comment_by_name_f(dset_id, ".", comment, error) + CALL check("h5oget_comment_by_name_f", error, total_error) + + IF(comment(1:15).NE.dset_comment(1:15))THEN + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + + ! Try with trailing blanks in the name + + CALL h5oget_comment_by_name_f(dset_id, ". ", comment, error) + CALL check("h5oget_comment_by_name_f", error, total_error) + + IF(comment(1:15).NE.dset_comment(1:15))THEN + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + + ! + ! Check optional parameter + ! + CALL h5oget_comment_by_name_f(dset_id, ". ", comment_lg, error, comment_size2) + CALL check("h5oget_comment_by_name_f", error, total_error) + + IF( comment_size2.NE.15)THEN + CALL check("h5oget_comment_by_name_f", -1, total_error) + ENDIF + + ! + ! Write the data to the dataset. + ! + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata2, dims2, error) + CALL check("h5dwrite_f", error, total_error) + + ! ************************* + ! CHECK H5OEXISTS_BY_NAME_F + ! ************************* + + ! Create a soft link to /G1 + CALL h5lcreate_soft_f("/G1", file_id, "/G1_LINK", error) + CALL check("h5lcreate_soft_f", error, total_error) + + + ! Create a soft link to /G1000, does not exist + CALL h5lcreate_soft_f("/G1000", file_id, "/G1_FALSE", error) + CALL check("h5lcreate_soft_f", error, total_error) + + ! Create a soft link to /G1_LINK + CALL h5lcreate_soft_f("/G1_FALSE", file_id, "/G2_FALSE", error) + CALL check("h5lcreate_soft_f", error, total_error) + + ! See if the link exists + CALL h5oexists_by_name_f(file_id,"/G1_LINK", link_exists, error) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should exist + IF(.NOT.link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + + chr_exact = "/G1_LINK" + ! See if the link exists + CALL h5oexists_by_name_f(file_id,chr_exact, link_exists, error, H5P_DEFAULT_F) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should exist + IF(.NOT.link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + + chr_lg = "/G1_LINK" + ! See if the link exists + CALL h5oexists_by_name_f(file_id,chr_lg, link_exists, error, H5P_DEFAULT_F) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should exist + IF(.NOT.link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + + chr_lg = "/G1_LINK " + ! See if the link exists + CALL h5oexists_by_name_f(file_id,chr_lg, link_exists, error, H5P_DEFAULT_F) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should exist + IF(.NOT.link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + + ! See if the link exists + CALL h5oexists_by_name_f(file_id,"/G1_FALSE", link_exists, error) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should not exist + IF(link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + + ! Check optional parameter + + CALL h5pcreate_f(H5P_LINK_ACCESS_F,plist,error) + CALL check("h5pcreate_f",error,total_error) + + nlinks = 2 + CALL h5pset_nlinks_f(plist, nlinks, error) + CALL check("h5pset_nlinks_f", error, total_error) + ! Ensure that nlinks was set successfully + nlinks = 0 + CALL h5pget_nlinks_f(plist, nlinks, error) + CALL check("h5pget_nlinks_f",error,total_error) + CALL verify("h5pget_nlinks_f", INT(nlinks), 2, total_error) + + ! See if the link exists + CALL h5oexists_by_name_f(file_id,"/G1_LINK", link_exists, error, plist) + CALL check("h5oexists_by_name_f", error, total_error) + + ! Object should exist + IF(.not.link_exists)THEN + CALL check("h5oexists_by_name_f", -1, total_error) + ENDIF + ! + ! Close and release resources. + ! + 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) + CALL h5gclose_f(group_id, error) + CALL check("h5gclose_f", error, total_error) + + ! Test opening an object by index, note + CALL h5oopen_by_idx_f(file_id, "/G1/G2/G3", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_hsize_t, group_id, error) + CALL check("h5oopen_by_idx_f", error, total_error) + + CALL h5oclose_f(group_id, error) + CALL check("h5gclose_f", error, total_error) + + ! + ! create property to pass copy options + ! + CALL h5pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) + CALL check("h5Pcreate_f", error, total_error) + + CALL h5pset_create_inter_group_f(lcpl_id, TRUE, error) + CALL check("H5Pset_create_inter_group_f", error, total_error) + ! + ! Check optional parameter lcpl_id, this would fail if lcpl_id was not specified + ! + CALL h5ocopy_f(file_id, "/G1/G2/G3/DS1", file_id, "/G1/G_cp1/DS2", error, lcpl_id=lcpl_id) + CALL check("h5ocopy_f -- W/ OPTION: lcpl_id", error ,total_error) + + CALL h5pclose_f(lcpl_id, error) + CALL check("h5pclose_f",error,total_error) + + CALL h5pcreate_f(H5P_OBJECT_COPY_F, ocpypl_id, error) + CALL check("h5Pcreate_f",error,total_error) + + CALL h5pset_copy_object_f(ocpypl_id, H5O_COPY_SHALLOW_HIERARCHY_F, error) + CALL check("H5Pset_copy_object_f",error,total_error) + + CALL h5ocopy_f(file_id, "/G1/G2", file_id, "/G1/G_cp2", error, ocpypl_id=ocpypl_id) + CALL check("h5ocopy_f",error,total_error) + + ! Makes sure the "DS1" dataset was not copied since we set a + ! flag to copy only immediate members of a group. + ! Therefore, this should fail. + CALL h5dopen_f(file_id, "/G1/G_cp2/DS1", dset_id, error) + IF(error.EQ.0)THEN + CALL check("h5ocopy_f -- W/ OPTION: ocpypl_id", -1, total_error) + ENDIF + + CALL h5pclose_f(ocpypl_id, error) + CALL check("h5pclose_f",error,total_error) + + ! create datatype + CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error) + CALL check("h5tcopy_f", error, total_error) + + ! create named datatype + CALL h5tcommit_f(file_id, NAME_DATATYPE_SIMPLE, tid, error) + CALL check("h5tcommit_f", error, total_error) + + ! close the datatype + CALL h5tclose_f(tid, error) + CALL check("h5tclose_f",error, total_error) + + CALL h5ocopy_f(file_id, NAME_DATATYPE_SIMPLE, file_id, NAME_DATATYPE_SIMPLE2, error) + CALL check("h5ocopy_f",error,total_error) + + ! open the datatype for copy + CALL h5topen_f(file_id, NAME_DATATYPE_SIMPLE, tid, error) + CALL check("h5topen_f",error,total_error) + + ! open the copied datatype + CALL h5topen_f(file_id, NAME_DATATYPE_SIMPLE2, tid2, error) + CALL check("h5topen_f",error,total_error) + + ! Compare the datatypes + CALL h5tequal_f(tid, tid2, flag, error) + IF(.NOT.flag)THEN + CALL check("h5ocopy_f FAILED", -1, total_error) + ENDIF + + ! close the destination datatype + CALL h5tclose_f(tid, error) + CALL check("h5tclose_f",error,total_error) + + ! close the destination datatype + CALL h5tclose_f(tid2, error) + CALL check("h5tclose_f",error,total_error) + + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f",error,total_error) + +END SUBROUTINE test_h5o_link + +!*************************************************************** +!** +!** test_h5o_plist(): Test object creation properties +!** +!*************************************************************** + +SUBROUTINE test_h5o_plist(total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(hid_t) :: fid ! HDF5 File ID + INTEGER(hid_t) :: grp, dset, dtype, dspace ! Object identifiers + INTEGER(hid_t) :: fapl ! File access property list + INTEGER(hid_t) :: gcpl, dcpl, tcpl ! Object creation properties + INTEGER :: def_max_compact, def_min_dense ! Default phase change parameters + INTEGER :: max_compact, min_dense ! Actual phase change parameters + INTEGER :: error ! Value returned from API calls + CHARACTER(LEN=7), PARAMETER :: TEST_FILENAME = 'test.h5' + + +! PRINT*,'Testing object creation properties' + + ! Make a FAPL that uses the "use the latest version of the format" flag + 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("H5Pcreate_f", error, total_error) + + ! Create a new HDF5 file + CALL H5Fcreate_f(TEST_FILENAME, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl) + CALL check("H5Fcreate_f", error, total_error) + + ! Create group, dataset & named datatype creation property lists + CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl, error) + CALL check("H5Pcreate_f", error, total_error) + CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) + CALL check("H5Pcreate_f", error, total_error) + CALL H5Pcreate_f(H5P_DATATYPE_CREATE_F, tcpl, error) + CALL check("H5Pcreate_f", error, total_error) + + ! Retrieve default attribute phase change values + CALL H5Pget_attr_phase_change_f(gcpl, def_max_compact, def_min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + + ! Set non-default attribute phase change values on each creation property list + CALL H5Pset_attr_phase_change_f(gcpl, def_max_compact+1, def_min_dense-1, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL H5Pset_attr_phase_change_f(dcpl, def_max_compact+1, def_min_dense-1, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL H5Pset_attr_phase_change_f(tcpl, def_max_compact+1, def_min_dense-1, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + + ! Retrieve attribute phase change values on each creation property list and verify + CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + ! Create a group, dataset, and committed datatype within the file, + ! using the respective type of creation property lists. + ! + + ! Create the group anonymously and link it in + CALL H5Gcreate_anon_f(fid, grp, error, gcpl_id=gcpl) + CALL check("H5Gcreate_anon_f", error, total_error) + + CALL H5Olink_f(grp, fid, "group", error) + CALL check("H5Olink_f", error, total_error) + + ! Commit the type inside the group anonymously and link it in + CALL h5tcopy_f(H5T_NATIVE_INTEGER, dtype, error) + CALL check("h5tcopy_f", error, total_error) + + CALL H5Tcommit_anon_f(fid, dtype, error, tcpl_id=tcpl) + CALL check("H5Tcommit_anon_f",error,total_error) + + CALL H5Olink_f(dtype, fid, "datatype", error) + CALL check("H5Olink_f", error, total_error) + + ! Create the dataspace for the dataset. + CALL h5screate_f(H5S_SCALAR_F, dspace, error) + CALL check("h5screate_f",error,total_error) + + ! Create the dataset anonymously and link it in + CALL H5Dcreate_anon_f(fid, H5T_NATIVE_INTEGER, dspace, dset, error, dcpl ) + CALL check("H5Dcreate_anon_f",error,total_error) + + CALL H5Olink_f(dset, fid, "dataset", error) + CALL check("H5Olink_f", error, total_error) + + CALL h5sclose_f(dspace, error) + CALL check("h5sclose_f",error,total_error) + + ! Close current creation property lists + CALL h5pclose_f(gcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(tcpl,error) + CALL check("h5pclose_f", error, total_error) + + ! Retrieve each object's creation property list + CALL H5Gget_create_plist_f(grp, gcpl, error) + CALL check("H5Gget_create_plist", error, total_error) + + CALL H5Tget_create_plist_f(dtype, tcpl, error) + CALL check("H5Tget_create_plist_f", error, total_error) + + CALL H5Dget_create_plist_f(dset, dcpl, error) + CALL check("H5Dget_create_plist_f", error, total_error) + + ! Retrieve attribute phase change values on each creation property list and verify + CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + ! Close current objects + CALL h5pclose_f(gcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(tcpl,error) + CALL check("h5pclose_f", error, total_error) + + CALL h5gclose_f(grp, error) + CALL check("h5gclose_f",error,total_error) + + CALL h5tclose_f(dtype, error) + CALL check("h5tclose_f",error,total_error) + CALL h5dclose_f(dset, error) + CALL check("h5dclose_f",error,total_error) + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + ! Re-open the file and check that the object creation properties persist + CALL h5fopen_f(TEST_FILENAME, H5F_ACC_RDONLY_F, fid, error, access_prp=fapl) + CALL check("H5fopen_f",error,total_error) + + ! Re-open objects + CALL H5Gopen_f(fid, "group", grp, error) + CALL check("h5gopen_f", error, total_error) + + CALL H5Topen_f(fid, "datatype", dtype,error) + CALL check("h5topen_f", error, total_error) + + CALL H5Dopen_f(fid, "dataset", dset, error) + CALL check("h5dopen_f", error, total_error) + + ! Retrieve each object's creation property list + CALL H5Gget_create_plist_f(grp, gcpl, error) + CALL check("H5Gget_create_plist", error, total_error) + + CALL H5Tget_create_plist_f(dtype, tcpl, error) + CALL check("H5Tget_create_plist_f", error, total_error) + + CALL H5Dget_create_plist_f(dset, dcpl, error) + CALL check("H5Dget_create_plist_f", error, total_error) + + ! Retrieve attribute phase change values on each creation property list and verify + CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) + CALL check("H5Pget_attr_phase_change_f", error, total_error) + CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) + CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) + + ! Close current objects + CALL h5pclose_f(gcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(dcpl,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(tcpl,error) + CALL check("h5pclose_f", error, total_error) + + CALL h5gclose_f(grp, error) + CALL check("h5gclose_f",error,total_error) + + CALL h5tclose_f(dtype, error) + CALL check("h5tclose_f",error,total_error) + CALL h5dclose_f(dset, error) + CALL check("h5dclose_f",error,total_error) + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error,total_error) + + ! Close the FAPL + CALL H5Pclose_f(fapl, error) + CALL check("H5Pclose_f", error, total_error) + +END SUBROUTINE test_h5o_plist + +END MODULE TH5O diff --git a/fortran/test/tH5O.f90 b/fortran/test/tH5O.f90 deleted file mode 100644 index 51e1d64..0000000 --- a/fortran/test/tH5O.f90 +++ /dev/null @@ -1,793 +0,0 @@ -!****h* root/fortran/test/tH5O.f90 -! -! NAME -! tH5O.f90 -! -! FUNCTION -! Basic testing of Fortran H5O APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! test_h5o, test_h5o_link, test_h5o_plist -! -!***** -MODULE TH5O - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -SUBROUTINE test_h5o(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - INTEGER :: error - - CALL test_h5o_plist(total_error) ! Test object creation properties - CALL test_h5o_link(total_error) ! Test object link routine - - IF(cleanup) CALL h5_cleanup_f("TestFile", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f("test", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - -END SUBROUTINE test_h5o - -!*************************************************************** -!** -!** test_h5o_link: Test creating link to object -!** -!*************************************************************** - -SUBROUTINE test_h5o_link(total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(HID_T) :: file_id - INTEGER(HID_T) :: group_id - INTEGER(HID_T) :: space_id - INTEGER(HID_T) :: dset_id - INTEGER(HID_T) :: type_id - INTEGER(HID_T) :: fapl_id - INTEGER(HID_T) :: lcpl_id - INTEGER(HID_T) :: ocpypl_id - CHARACTER(LEN=11), PARAMETER :: TEST_FILENAME = 'TestFile.h5' - INTEGER, PARAMETER :: TEST6_DIM1 = 2, TEST6_DIM2 = 5 -!EP INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/) - INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/TEST6_DIM1,TEST6_DIM2/) -!EP INTEGER, DIMENSION(1:TEST6_DIM1,1:TEST6_DIM2) :: wdata, rdata - INTEGER, DIMENSION(TEST6_DIM1,TEST6_DIM2) :: wdata, rdata - - INTEGER, PARAMETER :: TRUE = 1 - - LOGICAL :: committed ! Whether the named datatype is committed - - INTEGER :: i, j - INTEGER :: error ! Value returned from API calls - - CHARACTER(LEN=14) :: NAME_DATATYPE_SIMPLE="H5T_NATIVE_INT" - CHARACTER(LEN=16) :: NAME_DATATYPE_SIMPLE2="H5T_NATIVE_INT-2" - INTEGER(HID_T) :: tid, tid2 - LOGICAL :: flag - - ! Data for tested h5ocopy_f - CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1" - INTEGER , PARAMETER :: dim0 = 4 - - INTEGER(HSIZE_T), DIMENSION(1:1) :: dims2 = (/dim0/) ! size read/write buffer - INTEGER , DIMENSION(1:dim0) :: wdata2 ! Write buffer - LOGICAL :: link_exists - CHARACTER(LEN=8) :: chr_exact - CHARACTER(LEN=10) :: chr_lg - INTEGER(size_t) :: nlinks - INTEGER(HID_T) :: plist = -1 - - CHARACTER(LEN=20) :: dset_comment = "dataset comment" - CHARACTER(LEN=13) :: grp_comment = "group comment" - CHARACTER(LEN=10) :: comment_sm ! to small comment sized buffer - CHARACTER(LEN=15) :: comment ! exact comment sized buffer - CHARACTER(LEN=20) :: comment_lg ! large comment sized buffer - INTEGER(HSSIZE_T) :: comment_size - INTEGER(SIZE_T) :: comment_size2 - - ! Initialize the raw data - DO i = 1, TEST6_DIM1 - DO j = 1, TEST6_DIM2 - wdata(i,j) = i*j - ENDDO - ENDDO - - ! Create the dataspace - CALL h5screate_simple_f(2, dims, space_id, error) - CALL check("h5screate_simple_f",error,total_error) - - ! Create LCPL with intermediate group creation flag set - CALL H5Pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) - CALL check("h5Pcreate_f",error,total_error) - - CALL H5Pset_create_inter_group_f(lcpl_id, TRUE, error) - CALL check("H5Pset_create_inter_group_f",error,total_error) - - ! Loop over using new group format - ! for(new_format = FALSE; new_format <= TRUE; new_format++) { - - ! Make a FAPL that uses the "use the latest version of the format" bounds - CALL H5Pcreate_f(H5P_FILE_ACCESS_F,fapl_id,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_id, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) - CALL check("H5Pset_libver_bounds_f",error, total_error) - - ! Create a new HDF5 file - CALL H5Fcreate_f(TEST_FILENAME, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl_id) - CALL check("H5Fcreate_f", error, total_error) - - ! Close the FAPL - CALL h5pclose_f(fapl_id, error) - CALL check("h5pclose_f",error,total_error) - - ! Create and commit a datatype with no name - CALL H5Tcopy_f( H5T_NATIVE_INTEGER, type_id, error) - CALL check("H5Tcopy_F",error,total_error) - - CALL H5Tcommit_anon_f(file_id, type_id, error) ! using no optional parameters - CALL check("H5Tcommit_anon_F",error,total_error) - - CALL H5Tcommitted_f(type_id, committed, error) - CALL check("H5Tcommitted_f",error,total_error) - CALL verify("H5Tcommitted_f", committed, .TRUE., total_error) - - ! Create a dataset with no name using the committed datatype - CALL H5Dcreate_anon_f(file_id, type_id, space_id, dset_id, error ) ! using no optional parameters - CALL check("H5Dcreate_anon_f",error,total_error) - ! - ! Verify that we can write to and read from the dataset - ! - ! Write the data to the dataset - -!EP CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata, dims, error, & -!EP mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata, dims, error) - CALL check("h5dwrite_f", error, total_error) - - ! Read the data back -!EP CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, & -!EP mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) - CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error) - CALL check("h5dread_f", error, total_error) - - ! Verify the data - DO i = 1, TEST6_DIM1 - DO j = 1, TEST6_DIM2 - CALL verify("H5Dread_f",wdata(i,j),rdata(i,j),total_error) - wdata(i,j) = i*j - ENDDO - ENDDO - - ! Create a group with no name - - CALL H5Gcreate_anon_f(file_id, group_id, error) - CALL check("H5Gcreate_anon", error, total_error) - - ! Link nameless datatype into nameless group - CALL H5Olink_f(type_id, group_id, "datatype", error, H5P_DEFAULT_F) - CALL check("H5Olink_f", error, total_error) - - ! Link nameless dataset into nameless group with intermediate group - CALL H5Olink_f(dset_id, group_id, "inter_group/dataset", error, lcpl_id, H5P_DEFAULT_F) - CALL check("H5Olink_f", error, total_error) - - ! Close IDs for dataset and datatype - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f", error, total_error) - - ! Re-open datatype using new link - CALL H5Topen_f(group_id, "datatype", type_id, error) - CALL check("h5topen_f", error, total_error) - - ! Link nameless group to root group and close the group ID - CALL H5Olink_f(group_id, file_id, "/group", error) - CALL check("H5Olink_f", error, total_error) - - CALL h5gclose_f(group_id, error) - CALL check("h5gclose_f",error,total_error) - - ! Open dataset through root group and verify its data - CALL H5Dopen_f(file_id, "/group/inter_group/dataset", dset_id, error) - CALL check("test_lcpl.h5dopen_f", error, total_error) - - ! Read data from dataset -!EP CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, & -!EP H5S_ALL_F, H5S_ALL_F, xfer_prp = H5P_DEFAULT_F) - CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error) - CALL check("h5dread_f", error, total_error) - - ! Verify the data - DO i = 1, TEST6_DIM1 - DO j = 1, TEST6_DIM2 - CALL verify("H5Dread",wdata(i,j),rdata(i,j),total_error) - ENDDO - ENDDO - ! Close open IDs - - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f",error,total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f",error,total_error) - - ! Close remaining IDs - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5pclose_f(lcpl_id,error) - CALL check("h5pclose_f", error, total_error) - - ! ********************* - ! CHECK H5OCOPY_F - ! ********************* - - DO i = 1, dim0 - wdata2(i) = i-1 - ENDDO - ! - ! Create dataspace. Setting size to be the current size. - ! - CALL h5screate_simple_f(1, dims2, space_id, error) - CALL check("h5screate_simple_f", error, total_error) - ! - ! Create intermediate groups - ! - CALL h5gcreate_f(file_id,"/G1",group_id,error) - CALL check("h5gcreate_f", error, total_error) - CALL h5gcreate_f(file_id,"/G1/G2",group_id,error) - CALL check("h5gcreate_f", error, total_error) - CALL h5gcreate_f(file_id,"/G1/G2/G3",group_id,error) - CALL check("h5gcreate_f", error, total_error) - - ! Try putting a comment on the group /G1/G2/G3 by name - CALL h5oset_comment_by_name_f(file_id, "/G1/G2/G3", grp_comment, error) - CALL check("h5oset_comment_by_name_f", error, total_error) - - comment_lg = ' ' - - CALL h5oget_comment_by_name_f(file_id, "/G1/G2/G3", comment_lg, error) - CALL check("h5oget_comment_by_name_f", error, total_error) - - IF(comment_lg(1:13).NE.grp_comment)THEN - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - IF(comment_lg(14:20).NE.' ')THEN ! make sure no NULL terminator - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - - ! Try putting a comment on the group /G1/G2/G3 by name with trailing blanks - - CALL h5oset_comment_by_name_f(file_id, "/G1/G2/G3"//' ', grp_comment, error) - CALL check("h5oset_comment_by_name_f", error, total_error) - - comment_lg = ' ' - - CALL h5oget_comment_by_name_f(file_id, "/G1/G2/G3"//' ', comment_lg, error) - CALL check("h5oget_comment_by_name_f", error, total_error) - - IF(comment_lg(1:13).NE.grp_comment)THEN - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - IF(comment_lg(14:20).NE.' ')THEN ! make sure no NULL terminator - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - - ! - ! Create the dataset - ! - CALL h5dcreate_f(group_id, dataset, H5T_STD_I32LE, space_id, dset_id, error) - CALL check("h5dcreate_f", error, total_error) - - ! Putting a comment on the dataset - CALL h5oset_comment_f(dset_id, dset_comment, error) - CALL check("h5oset_comment_f", error, total_error) - - ! Try reading into a buffer that is the correct size - - CALL h5oget_comment_f(dset_id, comment, error) - CALL check("h5oget_comment_f", error, total_error) - - IF(comment(1:15).NE.dset_comment(1:15))THEN - CALL check("h5oget_comment_f", -1, total_error) - ENDIF - - ! Try reading into a buffer that is to small - - CALL h5oget_comment_f(dset_id, comment_sm, error) - CALL check("h5oget_comment_f", error, total_error) - - IF(comment_sm(1:10).NE.dset_comment(1:10))THEN - CALL check("h5oget_comment_f", -1, total_error) - ENDIF - - ! Try reading into a buffer that is larger then needed - - comment_lg = ' ' - - CALL h5oget_comment_f(dset_id, comment_lg, error) - CALL check("h5oget_comment_f", error, total_error) - - IF(comment_lg(1:15).NE.dset_comment)THEN - CALL check("h5oget_comment_f", -1, total_error) - ENDIF - IF(comment_lg(16:20).NE.' ')THEN ! make sure no NULL terminator - CALL check("h5oget_comment_f", -1, total_error) - ENDIF - ! - ! Check optional parameter - ! - CALL h5oget_comment_f(dset_id, comment_lg, error, comment_size) - CALL check("h5oget_comment_f", error, total_error) - - IF( comment_size.NE.15)THEN - CALL check("h5oget_comment_f", -1, total_error) - ENDIF - - ! CHECK h5oget_comment_by_name_f - - ! Try reading into a buffer that is the correct size - - CALL h5oget_comment_by_name_f(dset_id, ".", comment, error) - CALL check("h5oget_comment_by_name_f", error, total_error) - - IF(comment(1:15).NE.dset_comment(1:15))THEN - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - - ! Try with trailing blanks in the name - - CALL h5oget_comment_by_name_f(dset_id, ". ", comment, error) - CALL check("h5oget_comment_by_name_f", error, total_error) - - IF(comment(1:15).NE.dset_comment(1:15))THEN - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - - ! - ! Check optional parameter - ! - CALL h5oget_comment_by_name_f(dset_id, ". ", comment_lg, error, comment_size2) - CALL check("h5oget_comment_by_name_f", error, total_error) - - IF( comment_size2.NE.15)THEN - CALL check("h5oget_comment_by_name_f", -1, total_error) - ENDIF - - ! - ! Write the data to the dataset. - ! - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata2, dims2, error) - CALL check("h5dwrite_f", error, total_error) - - ! ************************* - ! CHECK H5OEXISTS_BY_NAME_F - ! ************************* - - ! Create a soft link to /G1 - CALL h5lcreate_soft_f("/G1", file_id, "/G1_LINK", error) - CALL check("h5lcreate_soft_f", error, total_error) - - - ! Create a soft link to /G1000, does not exist - CALL h5lcreate_soft_f("/G1000", file_id, "/G1_FALSE", error) - CALL check("h5lcreate_soft_f", error, total_error) - - ! Create a soft link to /G1_LINK - CALL h5lcreate_soft_f("/G1_FALSE", file_id, "/G2_FALSE", error) - CALL check("h5lcreate_soft_f", error, total_error) - - ! See if the link exists - CALL h5oexists_by_name_f(file_id,"/G1_LINK", link_exists, error) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should exist - IF(.NOT.link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - - chr_exact = "/G1_LINK" - ! See if the link exists - CALL h5oexists_by_name_f(file_id,chr_exact, link_exists, error, H5P_DEFAULT_F) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should exist - IF(.NOT.link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - - chr_lg = "/G1_LINK" - ! See if the link exists - CALL h5oexists_by_name_f(file_id,chr_lg, link_exists, error, H5P_DEFAULT_F) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should exist - IF(.NOT.link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - - chr_lg = "/G1_LINK " - ! See if the link exists - CALL h5oexists_by_name_f(file_id,chr_lg, link_exists, error, H5P_DEFAULT_F) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should exist - IF(.NOT.link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - - ! See if the link exists - CALL h5oexists_by_name_f(file_id,"/G1_FALSE", link_exists, error) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should not exist - IF(link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - - ! Check optional parameter - - CALL h5pcreate_f(H5P_LINK_ACCESS_F,plist,error) - CALL check("h5pcreate_f",error,total_error) - - nlinks = 2 - CALL h5pset_nlinks_f(plist, nlinks, error) - CALL check("h5pset_nlinks_f", error, total_error) - ! Ensure that nlinks was set successfully - nlinks = 0 - CALL h5pget_nlinks_f(plist, nlinks, error) - CALL check("h5pget_nlinks_f",error,total_error) - CALL verify("h5pget_nlinks_f", INT(nlinks), 2, total_error) - - ! See if the link exists - CALL h5oexists_by_name_f(file_id,"/G1_LINK", link_exists, error, plist) - CALL check("h5oexists_by_name_f", error, total_error) - - ! Object should exist - IF(.not.link_exists)THEN - CALL check("h5oexists_by_name_f", -1, total_error) - ENDIF - ! - ! Close and release resources. - ! - 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) - CALL h5gclose_f(group_id, error) - CALL check("h5gclose_f", error, total_error) - - ! Test opening an object by index, note - CALL h5oopen_by_idx_f(file_id, "/G1/G2/G3", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_hsize_t, group_id, error) - CALL check("h5oopen_by_idx_f", error, total_error) - - CALL h5oclose_f(group_id, error) - CALL check("h5gclose_f", error, total_error) - - ! - ! create property to pass copy options - ! - CALL h5pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) - CALL check("h5Pcreate_f", error, total_error) - - CALL h5pset_create_inter_group_f(lcpl_id, TRUE, error) - CALL check("H5Pset_create_inter_group_f", error, total_error) - ! - ! Check optional parameter lcpl_id, this would fail if lcpl_id was not specified - ! - CALL h5ocopy_f(file_id, "/G1/G2/G3/DS1", file_id, "/G1/G_cp1/DS2", error, lcpl_id=lcpl_id) - CALL check("h5ocopy_f -- W/ OPTION: lcpl_id", error ,total_error) - - CALL h5pclose_f(lcpl_id, error) - CALL check("h5pclose_f",error,total_error) - - CALL h5pcreate_f(H5P_OBJECT_COPY_F, ocpypl_id, error) - CALL check("h5Pcreate_f",error,total_error) - - CALL h5pset_copy_object_f(ocpypl_id, H5O_COPY_SHALLOW_HIERARCHY_F, error) - CALL check("H5Pset_copy_object_f",error,total_error) - - CALL h5ocopy_f(file_id, "/G1/G2", file_id, "/G1/G_cp2", error, ocpypl_id=ocpypl_id) - CALL check("h5ocopy_f",error,total_error) - - ! Makes sure the "DS1" dataset was not copied since we set a - ! flag to copy only immediate members of a group. - ! Therefore, this should fail. - CALL h5dopen_f(file_id, "/G1/G_cp2/DS1", dset_id, error) - IF(error.EQ.0)THEN - CALL check("h5ocopy_f -- W/ OPTION: ocpypl_id", -1, total_error) - ENDIF - - CALL h5pclose_f(ocpypl_id, error) - CALL check("h5pclose_f",error,total_error) - - ! create datatype - CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error) - CALL check("h5tcopy_f", error, total_error) - - ! create named datatype - CALL h5tcommit_f(file_id, NAME_DATATYPE_SIMPLE, tid, error) - CALL check("h5tcommit_f", error, total_error) - - ! close the datatype - CALL h5tclose_f(tid, error) - CALL check("h5tclose_f",error, total_error) - - CALL h5ocopy_f(file_id, NAME_DATATYPE_SIMPLE, file_id, NAME_DATATYPE_SIMPLE2, error) - CALL check("h5ocopy_f",error,total_error) - - ! open the datatype for copy - CALL h5topen_f(file_id, NAME_DATATYPE_SIMPLE, tid, error) - CALL check("h5topen_f",error,total_error) - - ! open the copied datatype - CALL h5topen_f(file_id, NAME_DATATYPE_SIMPLE2, tid2, error) - CALL check("h5topen_f",error,total_error) - - ! Compare the datatypes - CALL h5tequal_f(tid, tid2, flag, error) - IF(.NOT.flag)THEN - CALL check("h5ocopy_f FAILED", -1, total_error) - ENDIF - - ! close the destination datatype - CALL h5tclose_f(tid, error) - CALL check("h5tclose_f",error,total_error) - - ! close the destination datatype - CALL h5tclose_f(tid2, error) - CALL check("h5tclose_f",error,total_error) - - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f",error,total_error) - -END SUBROUTINE test_h5o_link - -!*************************************************************** -!** -!** test_h5o_plist(): Test object creation properties -!** -!*************************************************************** - -SUBROUTINE test_h5o_plist(total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(hid_t) :: fid ! HDF5 File ID - INTEGER(hid_t) :: grp, dset, dtype, dspace ! Object identifiers - INTEGER(hid_t) :: fapl ! File access property list - INTEGER(hid_t) :: gcpl, dcpl, tcpl ! Object creation properties - INTEGER :: def_max_compact, def_min_dense ! Default phase change parameters - INTEGER :: max_compact, min_dense ! Actual phase change parameters - INTEGER :: error ! Value returned from API calls - CHARACTER(LEN=7), PARAMETER :: TEST_FILENAME = 'test.h5' - - -! PRINT*,'Testing object creation properties' - - ! Make a FAPL that uses the "use the latest version of the format" flag - 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("H5Pcreate_f", error, total_error) - - ! Create a new HDF5 file - CALL H5Fcreate_f(TEST_FILENAME, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl) - CALL check("H5Fcreate_f", error, total_error) - - ! Create group, dataset & named datatype creation property lists - CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl, error) - CALL check("H5Pcreate_f", error, total_error) - CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) - CALL check("H5Pcreate_f", error, total_error) - CALL H5Pcreate_f(H5P_DATATYPE_CREATE_F, tcpl, error) - CALL check("H5Pcreate_f", error, total_error) - - ! Retrieve default attribute phase change values - CALL H5Pget_attr_phase_change_f(gcpl, def_max_compact, def_min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - - ! Set non-default attribute phase change values on each creation property list - CALL H5Pset_attr_phase_change_f(gcpl, def_max_compact+1, def_min_dense-1, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL H5Pset_attr_phase_change_f(dcpl, def_max_compact+1, def_min_dense-1, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL H5Pset_attr_phase_change_f(tcpl, def_max_compact+1, def_min_dense-1, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - - ! Retrieve attribute phase change values on each creation property list and verify - CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - ! Create a group, dataset, and committed datatype within the file, - ! using the respective type of creation property lists. - ! - - ! Create the group anonymously and link it in - CALL H5Gcreate_anon_f(fid, grp, error, gcpl_id=gcpl) - CALL check("H5Gcreate_anon_f", error, total_error) - - CALL H5Olink_f(grp, fid, "group", error) - CALL check("H5Olink_f", error, total_error) - - ! Commit the type inside the group anonymously and link it in - CALL h5tcopy_f(H5T_NATIVE_INTEGER, dtype, error) - CALL check("h5tcopy_f", error, total_error) - - CALL H5Tcommit_anon_f(fid, dtype, error, tcpl_id=tcpl) - CALL check("H5Tcommit_anon_f",error,total_error) - - CALL H5Olink_f(dtype, fid, "datatype", error) - CALL check("H5Olink_f", error, total_error) - - ! Create the dataspace for the dataset. - CALL h5screate_f(H5S_SCALAR_F, dspace, error) - CALL check("h5screate_f",error,total_error) - - ! Create the dataset anonymously and link it in - CALL H5Dcreate_anon_f(fid, H5T_NATIVE_INTEGER, dspace, dset, error, dcpl ) - CALL check("H5Dcreate_anon_f",error,total_error) - - CALL H5Olink_f(dset, fid, "dataset", error) - CALL check("H5Olink_f", error, total_error) - - CALL h5sclose_f(dspace, error) - CALL check("h5sclose_f",error,total_error) - - ! Close current creation property lists - CALL h5pclose_f(gcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(tcpl,error) - CALL check("h5pclose_f", error, total_error) - - ! Retrieve each object's creation property list - CALL H5Gget_create_plist_f(grp, gcpl, error) - CALL check("H5Gget_create_plist", error, total_error) - - CALL H5Tget_create_plist_f(dtype, tcpl, error) - CALL check("H5Tget_create_plist_f", error, total_error) - - CALL H5Dget_create_plist_f(dset, dcpl, error) - CALL check("H5Dget_create_plist_f", error, total_error) - - ! Retrieve attribute phase change values on each creation property list and verify - CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - ! Close current objects - CALL h5pclose_f(gcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(tcpl,error) - CALL check("h5pclose_f", error, total_error) - - CALL h5gclose_f(grp, error) - CALL check("h5gclose_f",error,total_error) - - CALL h5tclose_f(dtype, error) - CALL check("h5tclose_f",error,total_error) - CALL h5dclose_f(dset, error) - CALL check("h5dclose_f",error,total_error) - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - ! Re-open the file and check that the object creation properties persist - CALL h5fopen_f(TEST_FILENAME, H5F_ACC_RDONLY_F, fid, error, access_prp=fapl) - CALL check("H5fopen_f",error,total_error) - - ! Re-open objects - CALL H5Gopen_f(fid, "group", grp, error) - CALL check("h5gopen_f", error, total_error) - - CALL H5Topen_f(fid, "datatype", dtype,error) - CALL check("h5topen_f", error, total_error) - - CALL H5Dopen_f(fid, "dataset", dset, error) - CALL check("h5dopen_f", error, total_error) - - ! Retrieve each object's creation property list - CALL H5Gget_create_plist_f(grp, gcpl, error) - CALL check("H5Gget_create_plist", error, total_error) - - CALL H5Tget_create_plist_f(dtype, tcpl, error) - CALL check("H5Tget_create_plist_f", error, total_error) - - CALL H5Dget_create_plist_f(dset, dcpl, error) - CALL check("H5Dget_create_plist_f", error, total_error) - - ! Retrieve attribute phase change values on each creation property list and verify - CALL H5Pget_attr_phase_change_f(gcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(dcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - CALL H5Pget_attr_phase_change_f(tcpl, max_compact, min_dense, error) - CALL check("H5Pget_attr_phase_change_f", error, total_error) - CALL verify("H5Pget_attr_phase_change_f", max_compact, (def_max_compact + 1), total_error) - CALL verify("H5Pget_attr_phase_change_f", min_dense, (def_min_dense - 1), total_error) - - ! Close current objects - CALL h5pclose_f(gcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(dcpl,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(tcpl,error) - CALL check("h5pclose_f", error, total_error) - - CALL h5gclose_f(grp, error) - CALL check("h5gclose_f",error,total_error) - - CALL h5tclose_f(dtype, error) - CALL check("h5tclose_f",error,total_error) - CALL h5dclose_f(dset, error) - CALL check("h5dclose_f",error,total_error) - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error,total_error) - - ! Close the FAPL - CALL H5Pclose_f(fapl, error) - CALL check("H5Pclose_f", error, total_error) - -END SUBROUTINE test_h5o_plist - -END MODULE TH5O diff --git a/fortran/test/tH5O_F03.F90 b/fortran/test/tH5O_F03.F90 new file mode 100644 index 0000000..834308b --- /dev/null +++ b/fortran/test/tH5O_F03.F90 @@ -0,0 +1,555 @@ +!****h* root/fortran/test/tH5O_F03.f90 +! +! NAME +! tH5O_F03.f90 +! +! FUNCTION +! Test FORTRAN HDF5 H5O 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +! ***************************************** +! *** H 5 O T E S T S +! ***************************************** +MODULE visit_cb + + USE HDF5 + USE, INTRINSIC :: ISO_C_BINDING + + IMPLICIT NONE + + INTEGER, PARAMETER :: info_size = 9 + + !------------------------------------------------------------------------- + ! Function: visit_obj_cb + ! + ! Purpose: Callback routine for visiting objects in a file + ! + ! Return: Success: 0 + ! Failure: -1 + ! + ! Programmer: M.S. Breitenfeld + ! July 12, 2012 + ! Adopted from C test. + ! + !------------------------------------------------------------------------- + ! + ! Object visit structs + TYPE, bind(c) :: obj_visit_t + CHARACTER(KIND=C_CHAR), DIMENSION(1:180) :: path ! Path to object + INTEGER :: type_obj ! type of object + END TYPE obj_visit_t + + TYPE, bind(c) :: ovisit_ud_t + INTEGER :: idx ! Index in object visit structure + TYPE(obj_visit_t), DIMENSION(1:info_size) :: info ! Pointer to the object visit structure to use + END TYPE ovisit_ud_t + +CONTAINS + + INTEGER FUNCTION visit_obj_cb( group_id, name, oinfo, op_data) bind(C) + + IMPLICIT NONE + + INTEGER(HID_T), VALUE :: group_id + CHARACTER(LEN=1), DIMENSION(1:180) :: name + TYPE(h5o_info_t) :: oinfo + TYPE(ovisit_ud_t) :: op_data + + INTEGER :: len, i + INTEGER :: idx + + visit_obj_cb = 0 + + ! Since the name is generated in C and passed to a Fortran string, it + ! will be NULL terminated, so we need to find the end of the string. + + len = 1 + DO len = 1, 180 + IF(name(len) .EQ. C_NULL_CHAR) EXIT + ENDDO + + len = len - 1 + + ! Check for correct object information + + idx = op_data%idx + + DO i = 1, len + IF(op_data%info(idx)%path(i)(1:1) .NE. name(i)(1:1))THEN + visit_obj_cb = -1 + RETURN + ENDIF + + IF(op_data%info(idx)%type_obj .NE. oinfo%type)THEN + visit_obj_cb = -1 + RETURN + ENDIF + + ENDDO + + ! Advance to next location in expected output + op_data%idx = op_data%idx + 1 + + END FUNCTION visit_obj_cb + +END MODULE visit_cb + + +MODULE TH5O_F03 + +CONTAINS +!*************************************************************** +!** +!** test_h5o_refcount(): Test H5O refcounting functions. +!** +!*************************************************************** + +SUBROUTINE test_h5o_refcount(total_error) + + USE HDF5 + USE TH5_MISC + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=11), PARAMETER :: FILENAME = "th5o_ref.h5" + INTEGER, PARAMETER :: DIM0 = 5 + INTEGER, PARAMETER :: DIM1 = 10 + INTEGER(hid_t) :: fid ! HDF5 File ID + INTEGER(hid_t) :: grp, dset, dtype, dspace ! Object identifiers + TYPE(h5o_info_t) :: oinfo ! Object info struct + INTEGER(hsize_t), DIMENSION(1:2) :: dims + INTEGER :: error ! Value returned from API calls + + ! Create a new HDF5 file + CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid,error) + CALL check("h5fcreate_f", error, total_error) + + ! Create a group, dataset, and committed datatype within the file + ! Create the group + CALL h5gcreate_f(fid, "group", grp, error) + CALL check("h5gcreate_f",error, total_error) + + ! Commit the type inside the group + CALL h5tcopy_f(H5T_NATIVE_INTEGER, dtype, error) + CALL check("H5Tcopy_f",error, total_error) + CALL h5tcommit_f(fid, "datatype", dtype, error) + CALL check("h5tcommit_f", error, total_error) + + ! Create the data space for the dataset. + dims(1) = DIM0 + dims(2) = DIM1 + + CALL h5screate_simple_f(2, dims, dspace, error) + CALL check("h5screate_simple_f", error, total_error) + + ! Create the dataset. + CALL h5dcreate_f(fid, "dataset", H5T_NATIVE_INTEGER, dspace, dset, error) + CALL check("h5dcreate_f", error, total_error) + CALL h5sclose_f(dspace, error) + CALL check("h5sclose_f", error, total_error) + + ! Get ref counts for each object. They should all be 1, since each object has a hard link. + CALL h5oget_info_by_name_f(fid, "group", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + + ! Check h5oget_info + CALL h5oget_info_f(grp, oinfo, error) + CALL check("h5oget_info_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_f", -1, total_error) + ENDIF + IF(oinfo%type.NE.H5O_TYPE_GROUP_F)THEN + CALL check("h5oget_info_f", -1, total_error) + ENDIF + + ! Increment each object's reference count. + CALL h5oincr_refcount_f(grp, error) + CALL check("h5oincr_refcount_f", error, total_error) + CALL h5oincr_refcount_f(dtype, error) + CALL check("h5oincr_refcount_f", error, total_error) + CALL h5oincr_refcount_f(dset, error) + CALL check("h5oincr_refcount_f", error, total_error) + + ! Get ref counts for each object. They should all be 2 now. + CALL h5oget_info_by_name_f(fid, "group", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.2)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.2)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.2)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + + ! Decrement the reference counts and check that they decrease back to 1. + CALL h5odecr_refcount_f(grp, error) + CALL check("h5oincr_refcount_f", error, total_error) + CALL h5odecr_refcount_f(dtype, error) + CALL check("h5oincr_refcount_f", error, total_error) + CALL h5odecr_refcount_f(dset, error) + CALL check("h5oincr_refcount_f", error, total_error) + + CALL h5oget_info_by_name_f(fid, "group", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) + CALL check("h5oget_info_by_name_f", error, total_error) + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_name_f", -1, total_error) + ENDIF + + CALL h5gclose_f(grp, error) + CALL check("h5gclose_f",error, total_error) + CALL h5tclose_f(dtype, error) + CALL check("h5tclose_f",error, total_error) + CALL h5dclose_f(dset, error) + CALL check("h5dclose_f",error, total_error) + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error, total_error) + +END SUBROUTINE test_h5o_refcount + +!**************************************************************** +!** +!** test_h5o_refcount(): Test H5O visit functions. +!** +!**************************************************************** + +SUBROUTINE obj_visit(total_error) + + USE HDF5 + USE TH5_MISC + + USE visit_cb + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER, INTENT(INOUT) :: total_error + + TYPE(ovisit_ud_t), TARGET :: udata ! User-data for visiting + INTEGER(hid_t) :: fid = -1 + TYPE(C_PTR) :: f_ptr + TYPE(C_FUNPTR) :: fun_ptr + CHARACTER(LEN=180) :: object_name + INTEGER :: ret_val + INTEGER :: error + + ! Construct "interesting" file to visit + CALL build_visit_file(fid) + + ! Inialize udata for testing purposes + udata%info(1)%path(1:1) ="." + udata%info(1)%type_obj = H5O_TYPE_GROUP_F + udata%info(2)%path(1:12) = & + (/"D","a","t","a","s","e","t","_","z","e","r","o"/) + udata%info(2)%type_obj =H5O_TYPE_DATASET_F + udata%info(3)%path(1:6) = & + (/"G","r","o","u","p","1"/) + udata%info(3)%type_obj = H5O_TYPE_GROUP_F + udata%info(4)%path(1:18) =& + (/"G","r","o","u","p","1","/","D","a","t","a","s","e","t","_","o","n","e"/) + udata%info(4)%type_obj = H5O_TYPE_DATASET_F + udata%info(5)%path(1:13) =& + (/"G","r","o","u","p","1","/","G","r","o","u","p","2"/) + udata%info(5)%type_obj = H5O_TYPE_GROUP_F + udata%info(6)%path(1:25) =& + (/"G","r","o","u","p","1","/","G","r","o","u","p","2","/","D","a","t","a","s","e","t","_","t","w","o"/) + udata%info(6)%type_obj = H5O_TYPE_DATASET_F + udata%info(7)%path(1:22) =& + (/"G","r","o","u","p","1","/","G","r","o","u","p","2","/","T","y","p","e","_","t","w","o"/) + udata%info(7)%type_obj = H5O_TYPE_NAMED_DATATYPE_F + udata%info(8)%path(1:15) =& + (/"G","r","o","u","p","1","/","T","y","p","e","_","o","n","e"/) + udata%info(8)%type_obj = H5O_TYPE_NAMED_DATATYPE_F + udata%info(9)%path(1:9) =& + (/"T","y","p","e","_","z","e","r","o"/) + udata%info(9)%type_obj = H5O_TYPE_NAMED_DATATYPE_F + + ! Visit all the objects reachable from the root group (with file ID) + udata%idx = 1 + + fun_ptr = C_FUNLOC(visit_obj_cb) + f_ptr = C_LOC(udata) + + ! Test h5ovisit_f + CALL h5ovisit_f(fid, H5_INDEX_NAME_F, H5_ITER_INC_F, fun_ptr, f_ptr, ret_val, error) + CALL check("h5ovisit_f", error, total_error) + IF(ret_val.LT.0)THEN + CALL check("h5ovisit_f", -1, total_error) + ENDIF + + ! Test h5ovisit_by_name_f + + object_name = "/" + udata%idx = 1 + + CALL h5ovisit_by_name_f(fid, object_name, H5_INDEX_NAME_F, H5_ITER_INC_F, fun_ptr, f_ptr, ret_val, error) + CALL check("h5ovisit_by_name_f", error, total_error) + IF(ret_val.LT.0)THEN + CALL check("h5ovisit_by_name_f", -1, total_error) + ENDIF + + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f",error, total_error) + +END SUBROUTINE obj_visit + +!**************************************************************** +!** +!** test_h5o_refcount(): Test H5O info functions. +!** +!**************************************************************** + +SUBROUTINE obj_info(total_error) + + USE HDF5 + USE TH5_MISC + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(hid_t) :: fid = -1 ! File ID + INTEGER(hid_t) :: gid = -1, gid2 = -1 ! Group IDs + INTEGER(hid_t) :: did ! Dataset ID + INTEGER(hid_t) :: sid ! Dataspace ID + TYPE(hobj_ref_t_f), TARGET :: wref ! Reference to write + TYPE(hobj_ref_t_f), TARGET :: rref ! Reference to read + TYPE(H5O_info_t) :: oinfo ! Object info struct + INTEGER :: error + TYPE(C_PTR) :: f_ptr + + CHARACTER(LEN=6) :: GROUPNAME = "/group" + CHARACTER(LEN=6) :: GROUPNAME2 = "group2" + CHARACTER(LEN=6) :: GROUPNAME3 = "group3" + CHARACTER(LEN=5) :: DSETNAME = "/dset" + CHARACTER(LEN=5) :: DSETNAME2 = "dset2" + + ! Create file with a group and a dataset containing an object reference to the group + CALL h5fcreate_f("get_info.h5", H5F_ACC_TRUNC_F, fid, error) + CALL check("h5fcreate_f",error, total_error) + + ! Create dataspace to use for dataset + CALL h5screate_f(H5S_SCALAR_F, sid, error) + CALL check("h5screate_f",error,total_error) + + ! Create group to refer to + CALL h5gcreate_f(fid, GROUPNAME, gid, error) + CALL check("h5gcreate_f",error,total_error) + + ! Create nested groups + CALL h5gcreate_f(gid, GROUPNAME2, gid2, error) + CALL check("h5gcreate_f",error,total_error) + CALL h5gclose_f(gid2, error) + CALL check("h5gclose_f",error,total_error) + + CALL h5gcreate_f(gid, GROUPNAME3, gid2, error) + CALL check("h5gcreate_f",error,total_error) + CALL h5gclose_f(gid2, error) + CALL check("h5gclose_f",error,total_error) + + ! Create bottom dataset + CALL h5dcreate_f(gid, DSETNAME2, H5T_NATIVE_INTEGER, sid, did, error) + CALL check("h5dcreate_f",error, total_error) + + CALL h5dclose_f(did, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5gclose_f(gid, error) + CALL check("h5gclose_f",error,total_error) + + ! Create dataset + CALL h5dcreate_f(fid, DSETNAME, H5T_STD_REF_OBJ, sid, did, error) + CALL check("h5dcreate_f",error, total_error) + + f_ptr = C_LOC(wref) + + ! Create reference to group + CALL h5rcreate_f(fid, GROUPNAME, H5R_OBJECT_F, f_ptr, error) + CALL check("h5rcreate_f",error, total_error) + + ! Write reference to disk + CALL h5dwrite_f(did, H5T_STD_REF_OBJ, f_ptr, error) + CALL check("h5dwrite_f",error, total_error) + + ! Close objects + 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 h5fclose_f(fid, error) + CALL check("h5fclose_f", error, total_error) + + ! Re-open file + CALL h5fopen_f("get_info.h5", H5F_ACC_RDWR_F, fid, error) + CALL check("h5fopen_f", error, total_error) + + ! Re-open dataset + CALL h5dopen_f(fid, DSETNAME, did, error) + CALL check("h5dopen_f", error, total_error) + + ! Read in the reference + + f_ptr = C_LOC(rref) + + CALL h5dread_f(did, H5T_STD_REF_OBJ, f_ptr, error) + CALL check("H5Dread_f",error, total_error) + + ! Dereference to get the group + + CALL h5rdereference_f(did, H5R_OBJECT_F, f_ptr, gid, error) + CALL check("h5rdereference_f", error, total_error) + + CALL h5oget_info_by_idx_f(gid, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_hsize_t, oinfo, error) + CALL check("h5oget_info_by_idx_f", error, total_error) + + IF(oinfo%rc.NE.1)THEN + CALL check("h5oget_info_by_idx_f", -1, total_error) + ENDIF + + IF(oinfo%type.NE.H5O_TYPE_DATASET_F)THEN + CALL check("h5oget_info_by_idx_f", -1, total_error) + ENDIF + + ! Close objects + CALL h5dclose_f(did, error) + CALL check("h5dclose_f", error, total_error) + CALL h5gclose_f(gid, error) + CALL check("h5sclose_f", error, total_error) + CALL h5fclose_f(fid, error) + CALL check("h5fclose_f", error, total_error) + +END SUBROUTINE obj_info + +!------------------------------------------------------------------------- +! Function: build_visit_file +! +! Purpose: Build an "interesting" file to use for visiting links & objects +! +! Programmer: M. Scot Breitenfeld +! July 12, 2012 +! NOTE: Adapted from C test. +! +!------------------------------------------------------------------------- +! + +SUBROUTINE build_visit_file(fid) + + USE HDF5 + USE TH5_MISC + IMPLICIT NONE + + INTEGER(hid_t) :: fid ! File ID + INTEGER(hid_t) :: gid = -1, gid2 = -1 ! Group IDs + INTEGER(hid_t) :: sid = -1 ! Dataspace ID + INTEGER(hid_t) :: did = -1 ! Dataset ID + INTEGER(hid_t) :: tid = -1 ! Datatype ID + CHARACTER(LEN=20) :: filename = 'visit.h5' + INTEGER :: error + + ! Create file for visiting + CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error) + + ! Create group + CALL H5Gcreate_f(fid, "/Group1", gid, error) + + ! Create nested group + CALL H5Gcreate_f(gid, "Group2", gid2, error) + + ! Close groups + CALL h5gclose_f(gid2, error) + CALL h5gclose_f(gid, error) + + ! Create soft links to groups created + CALL H5Lcreate_soft_f("/Group1", fid, "/soft_one", error) + CALL H5Lcreate_soft_f("/Group1/Group2", fid, "/soft_two", error) + + ! Create dangling soft link + CALL H5Lcreate_soft_f("nowhere", fid, "/soft_dangle", error) + + ! Create hard links to all groups + CALL H5Lcreate_hard_f(fid, "/", fid, "hard_zero", error) + CALL H5Lcreate_hard_f(fid, "/Group1", fid, "hard_one", error) + CALL H5Lcreate_hard_f(fid, "/Group1/Group2", fid, "hard_two", error) + + ! Create loops w/hard links + CALL H5Lcreate_hard_f(fid, "/Group1", fid, "/Group1/hard_one", error) + CALL H5Lcreate_hard_f(fid, "/", fid, "/Group1/Group2/hard_zero", error) + + ! Create dataset in each group + CALL H5Screate_f(H5S_SCALAR_F, sid, error) + + CALL H5Dcreate_f(fid, "/Dataset_zero", H5T_NATIVE_INTEGER, sid, did, error) + CALL H5Dclose_f(did, error) + + CALL H5Dcreate_f(fid, "/Group1/Dataset_one", H5T_NATIVE_INTEGER, sid, did, error) + CALL H5Dclose_f(did, error) + + CALL H5Dcreate_f(fid, "/Group1/Group2/Dataset_two", H5T_NATIVE_INTEGER, sid, did, error) + CALL H5Dclose_f(did, error) + + CALL H5Sclose_f(sid, error) + + ! Create named datatype in each group + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) + + CALL H5Tcommit_f(fid, "/Type_zero", tid, error) + CALL H5Tclose_f(tid, error) + + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) + CALL H5Tcommit_f(fid, "/Group1/Type_one", tid, error) + CALL H5Tclose_f(tid, error) + + CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) + CALL H5Tcommit_f(fid, "/Group1/Group2/Type_two", tid, error) + CALL H5Tclose_f(tid, error) + +END SUBROUTINE build_visit_file + +END MODULE TH5O_F03 diff --git a/fortran/test/tH5O_F03.f90 b/fortran/test/tH5O_F03.f90 deleted file mode 100644 index 834308b..0000000 --- a/fortran/test/tH5O_F03.f90 +++ /dev/null @@ -1,555 +0,0 @@ -!****h* root/fortran/test/tH5O_F03.f90 -! -! NAME -! tH5O_F03.f90 -! -! FUNCTION -! Test FORTRAN HDF5 H5O 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -! ***************************************** -! *** H 5 O T E S T S -! ***************************************** -MODULE visit_cb - - USE HDF5 - USE, INTRINSIC :: ISO_C_BINDING - - IMPLICIT NONE - - INTEGER, PARAMETER :: info_size = 9 - - !------------------------------------------------------------------------- - ! Function: visit_obj_cb - ! - ! Purpose: Callback routine for visiting objects in a file - ! - ! Return: Success: 0 - ! Failure: -1 - ! - ! Programmer: M.S. Breitenfeld - ! July 12, 2012 - ! Adopted from C test. - ! - !------------------------------------------------------------------------- - ! - ! Object visit structs - TYPE, bind(c) :: obj_visit_t - CHARACTER(KIND=C_CHAR), DIMENSION(1:180) :: path ! Path to object - INTEGER :: type_obj ! type of object - END TYPE obj_visit_t - - TYPE, bind(c) :: ovisit_ud_t - INTEGER :: idx ! Index in object visit structure - TYPE(obj_visit_t), DIMENSION(1:info_size) :: info ! Pointer to the object visit structure to use - END TYPE ovisit_ud_t - -CONTAINS - - INTEGER FUNCTION visit_obj_cb( group_id, name, oinfo, op_data) bind(C) - - IMPLICIT NONE - - INTEGER(HID_T), VALUE :: group_id - CHARACTER(LEN=1), DIMENSION(1:180) :: name - TYPE(h5o_info_t) :: oinfo - TYPE(ovisit_ud_t) :: op_data - - INTEGER :: len, i - INTEGER :: idx - - visit_obj_cb = 0 - - ! Since the name is generated in C and passed to a Fortran string, it - ! will be NULL terminated, so we need to find the end of the string. - - len = 1 - DO len = 1, 180 - IF(name(len) .EQ. C_NULL_CHAR) EXIT - ENDDO - - len = len - 1 - - ! Check for correct object information - - idx = op_data%idx - - DO i = 1, len - IF(op_data%info(idx)%path(i)(1:1) .NE. name(i)(1:1))THEN - visit_obj_cb = -1 - RETURN - ENDIF - - IF(op_data%info(idx)%type_obj .NE. oinfo%type)THEN - visit_obj_cb = -1 - RETURN - ENDIF - - ENDDO - - ! Advance to next location in expected output - op_data%idx = op_data%idx + 1 - - END FUNCTION visit_obj_cb - -END MODULE visit_cb - - -MODULE TH5O_F03 - -CONTAINS -!*************************************************************** -!** -!** test_h5o_refcount(): Test H5O refcounting functions. -!** -!*************************************************************** - -SUBROUTINE test_h5o_refcount(total_error) - - USE HDF5 - USE TH5_MISC - USE ISO_C_BINDING - IMPLICIT NONE - - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=11), PARAMETER :: FILENAME = "th5o_ref.h5" - INTEGER, PARAMETER :: DIM0 = 5 - INTEGER, PARAMETER :: DIM1 = 10 - INTEGER(hid_t) :: fid ! HDF5 File ID - INTEGER(hid_t) :: grp, dset, dtype, dspace ! Object identifiers - TYPE(h5o_info_t) :: oinfo ! Object info struct - INTEGER(hsize_t), DIMENSION(1:2) :: dims - INTEGER :: error ! Value returned from API calls - - ! Create a new HDF5 file - CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid,error) - CALL check("h5fcreate_f", error, total_error) - - ! Create a group, dataset, and committed datatype within the file - ! Create the group - CALL h5gcreate_f(fid, "group", grp, error) - CALL check("h5gcreate_f",error, total_error) - - ! Commit the type inside the group - CALL h5tcopy_f(H5T_NATIVE_INTEGER, dtype, error) - CALL check("H5Tcopy_f",error, total_error) - CALL h5tcommit_f(fid, "datatype", dtype, error) - CALL check("h5tcommit_f", error, total_error) - - ! Create the data space for the dataset. - dims(1) = DIM0 - dims(2) = DIM1 - - CALL h5screate_simple_f(2, dims, dspace, error) - CALL check("h5screate_simple_f", error, total_error) - - ! Create the dataset. - CALL h5dcreate_f(fid, "dataset", H5T_NATIVE_INTEGER, dspace, dset, error) - CALL check("h5dcreate_f", error, total_error) - CALL h5sclose_f(dspace, error) - CALL check("h5sclose_f", error, total_error) - - ! Get ref counts for each object. They should all be 1, since each object has a hard link. - CALL h5oget_info_by_name_f(fid, "group", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - - ! Check h5oget_info - CALL h5oget_info_f(grp, oinfo, error) - CALL check("h5oget_info_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_f", -1, total_error) - ENDIF - IF(oinfo%type.NE.H5O_TYPE_GROUP_F)THEN - CALL check("h5oget_info_f", -1, total_error) - ENDIF - - ! Increment each object's reference count. - CALL h5oincr_refcount_f(grp, error) - CALL check("h5oincr_refcount_f", error, total_error) - CALL h5oincr_refcount_f(dtype, error) - CALL check("h5oincr_refcount_f", error, total_error) - CALL h5oincr_refcount_f(dset, error) - CALL check("h5oincr_refcount_f", error, total_error) - - ! Get ref counts for each object. They should all be 2 now. - CALL h5oget_info_by_name_f(fid, "group", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.2)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.2)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.2)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - - ! Decrement the reference counts and check that they decrease back to 1. - CALL h5odecr_refcount_f(grp, error) - CALL check("h5oincr_refcount_f", error, total_error) - CALL h5odecr_refcount_f(dtype, error) - CALL check("h5oincr_refcount_f", error, total_error) - CALL h5odecr_refcount_f(dset, error) - CALL check("h5oincr_refcount_f", error, total_error) - - CALL h5oget_info_by_name_f(fid, "group", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "datatype", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - CALL h5oget_info_by_name_f(fid, "dataset", oinfo, error) - CALL check("h5oget_info_by_name_f", error, total_error) - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_name_f", -1, total_error) - ENDIF - - CALL h5gclose_f(grp, error) - CALL check("h5gclose_f",error, total_error) - CALL h5tclose_f(dtype, error) - CALL check("h5tclose_f",error, total_error) - CALL h5dclose_f(dset, error) - CALL check("h5dclose_f",error, total_error) - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error, total_error) - -END SUBROUTINE test_h5o_refcount - -!**************************************************************** -!** -!** test_h5o_refcount(): Test H5O visit functions. -!** -!**************************************************************** - -SUBROUTINE obj_visit(total_error) - - USE HDF5 - USE TH5_MISC - - USE visit_cb - USE ISO_C_BINDING - IMPLICIT NONE - - INTEGER, INTENT(INOUT) :: total_error - - TYPE(ovisit_ud_t), TARGET :: udata ! User-data for visiting - INTEGER(hid_t) :: fid = -1 - TYPE(C_PTR) :: f_ptr - TYPE(C_FUNPTR) :: fun_ptr - CHARACTER(LEN=180) :: object_name - INTEGER :: ret_val - INTEGER :: error - - ! Construct "interesting" file to visit - CALL build_visit_file(fid) - - ! Inialize udata for testing purposes - udata%info(1)%path(1:1) ="." - udata%info(1)%type_obj = H5O_TYPE_GROUP_F - udata%info(2)%path(1:12) = & - (/"D","a","t","a","s","e","t","_","z","e","r","o"/) - udata%info(2)%type_obj =H5O_TYPE_DATASET_F - udata%info(3)%path(1:6) = & - (/"G","r","o","u","p","1"/) - udata%info(3)%type_obj = H5O_TYPE_GROUP_F - udata%info(4)%path(1:18) =& - (/"G","r","o","u","p","1","/","D","a","t","a","s","e","t","_","o","n","e"/) - udata%info(4)%type_obj = H5O_TYPE_DATASET_F - udata%info(5)%path(1:13) =& - (/"G","r","o","u","p","1","/","G","r","o","u","p","2"/) - udata%info(5)%type_obj = H5O_TYPE_GROUP_F - udata%info(6)%path(1:25) =& - (/"G","r","o","u","p","1","/","G","r","o","u","p","2","/","D","a","t","a","s","e","t","_","t","w","o"/) - udata%info(6)%type_obj = H5O_TYPE_DATASET_F - udata%info(7)%path(1:22) =& - (/"G","r","o","u","p","1","/","G","r","o","u","p","2","/","T","y","p","e","_","t","w","o"/) - udata%info(7)%type_obj = H5O_TYPE_NAMED_DATATYPE_F - udata%info(8)%path(1:15) =& - (/"G","r","o","u","p","1","/","T","y","p","e","_","o","n","e"/) - udata%info(8)%type_obj = H5O_TYPE_NAMED_DATATYPE_F - udata%info(9)%path(1:9) =& - (/"T","y","p","e","_","z","e","r","o"/) - udata%info(9)%type_obj = H5O_TYPE_NAMED_DATATYPE_F - - ! Visit all the objects reachable from the root group (with file ID) - udata%idx = 1 - - fun_ptr = C_FUNLOC(visit_obj_cb) - f_ptr = C_LOC(udata) - - ! Test h5ovisit_f - CALL h5ovisit_f(fid, H5_INDEX_NAME_F, H5_ITER_INC_F, fun_ptr, f_ptr, ret_val, error) - CALL check("h5ovisit_f", error, total_error) - IF(ret_val.LT.0)THEN - CALL check("h5ovisit_f", -1, total_error) - ENDIF - - ! Test h5ovisit_by_name_f - - object_name = "/" - udata%idx = 1 - - CALL h5ovisit_by_name_f(fid, object_name, H5_INDEX_NAME_F, H5_ITER_INC_F, fun_ptr, f_ptr, ret_val, error) - CALL check("h5ovisit_by_name_f", error, total_error) - IF(ret_val.LT.0)THEN - CALL check("h5ovisit_by_name_f", -1, total_error) - ENDIF - - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f",error, total_error) - -END SUBROUTINE obj_visit - -!**************************************************************** -!** -!** test_h5o_refcount(): Test H5O info functions. -!** -!**************************************************************** - -SUBROUTINE obj_info(total_error) - - USE HDF5 - USE TH5_MISC - USE ISO_C_BINDING - IMPLICIT NONE - - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(hid_t) :: fid = -1 ! File ID - INTEGER(hid_t) :: gid = -1, gid2 = -1 ! Group IDs - INTEGER(hid_t) :: did ! Dataset ID - INTEGER(hid_t) :: sid ! Dataspace ID - TYPE(hobj_ref_t_f), TARGET :: wref ! Reference to write - TYPE(hobj_ref_t_f), TARGET :: rref ! Reference to read - TYPE(H5O_info_t) :: oinfo ! Object info struct - INTEGER :: error - TYPE(C_PTR) :: f_ptr - - CHARACTER(LEN=6) :: GROUPNAME = "/group" - CHARACTER(LEN=6) :: GROUPNAME2 = "group2" - CHARACTER(LEN=6) :: GROUPNAME3 = "group3" - CHARACTER(LEN=5) :: DSETNAME = "/dset" - CHARACTER(LEN=5) :: DSETNAME2 = "dset2" - - ! Create file with a group and a dataset containing an object reference to the group - CALL h5fcreate_f("get_info.h5", H5F_ACC_TRUNC_F, fid, error) - CALL check("h5fcreate_f",error, total_error) - - ! Create dataspace to use for dataset - CALL h5screate_f(H5S_SCALAR_F, sid, error) - CALL check("h5screate_f",error,total_error) - - ! Create group to refer to - CALL h5gcreate_f(fid, GROUPNAME, gid, error) - CALL check("h5gcreate_f",error,total_error) - - ! Create nested groups - CALL h5gcreate_f(gid, GROUPNAME2, gid2, error) - CALL check("h5gcreate_f",error,total_error) - CALL h5gclose_f(gid2, error) - CALL check("h5gclose_f",error,total_error) - - CALL h5gcreate_f(gid, GROUPNAME3, gid2, error) - CALL check("h5gcreate_f",error,total_error) - CALL h5gclose_f(gid2, error) - CALL check("h5gclose_f",error,total_error) - - ! Create bottom dataset - CALL h5dcreate_f(gid, DSETNAME2, H5T_NATIVE_INTEGER, sid, did, error) - CALL check("h5dcreate_f",error, total_error) - - CALL h5dclose_f(did, error) - CALL check("h5dclose_f", error, total_error) - - CALL h5gclose_f(gid, error) - CALL check("h5gclose_f",error,total_error) - - ! Create dataset - CALL h5dcreate_f(fid, DSETNAME, H5T_STD_REF_OBJ, sid, did, error) - CALL check("h5dcreate_f",error, total_error) - - f_ptr = C_LOC(wref) - - ! Create reference to group - CALL h5rcreate_f(fid, GROUPNAME, H5R_OBJECT_F, f_ptr, error) - CALL check("h5rcreate_f",error, total_error) - - ! Write reference to disk - CALL h5dwrite_f(did, H5T_STD_REF_OBJ, f_ptr, error) - CALL check("h5dwrite_f",error, total_error) - - ! Close objects - 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 h5fclose_f(fid, error) - CALL check("h5fclose_f", error, total_error) - - ! Re-open file - CALL h5fopen_f("get_info.h5", H5F_ACC_RDWR_F, fid, error) - CALL check("h5fopen_f", error, total_error) - - ! Re-open dataset - CALL h5dopen_f(fid, DSETNAME, did, error) - CALL check("h5dopen_f", error, total_error) - - ! Read in the reference - - f_ptr = C_LOC(rref) - - CALL h5dread_f(did, H5T_STD_REF_OBJ, f_ptr, error) - CALL check("H5Dread_f",error, total_error) - - ! Dereference to get the group - - CALL h5rdereference_f(did, H5R_OBJECT_F, f_ptr, gid, error) - CALL check("h5rdereference_f", error, total_error) - - CALL h5oget_info_by_idx_f(gid, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, 0_hsize_t, oinfo, error) - CALL check("h5oget_info_by_idx_f", error, total_error) - - IF(oinfo%rc.NE.1)THEN - CALL check("h5oget_info_by_idx_f", -1, total_error) - ENDIF - - IF(oinfo%type.NE.H5O_TYPE_DATASET_F)THEN - CALL check("h5oget_info_by_idx_f", -1, total_error) - ENDIF - - ! Close objects - CALL h5dclose_f(did, error) - CALL check("h5dclose_f", error, total_error) - CALL h5gclose_f(gid, error) - CALL check("h5sclose_f", error, total_error) - CALL h5fclose_f(fid, error) - CALL check("h5fclose_f", error, total_error) - -END SUBROUTINE obj_info - -!------------------------------------------------------------------------- -! Function: build_visit_file -! -! Purpose: Build an "interesting" file to use for visiting links & objects -! -! Programmer: M. Scot Breitenfeld -! July 12, 2012 -! NOTE: Adapted from C test. -! -!------------------------------------------------------------------------- -! - -SUBROUTINE build_visit_file(fid) - - USE HDF5 - USE TH5_MISC - IMPLICIT NONE - - INTEGER(hid_t) :: fid ! File ID - INTEGER(hid_t) :: gid = -1, gid2 = -1 ! Group IDs - INTEGER(hid_t) :: sid = -1 ! Dataspace ID - INTEGER(hid_t) :: did = -1 ! Dataset ID - INTEGER(hid_t) :: tid = -1 ! Datatype ID - CHARACTER(LEN=20) :: filename = 'visit.h5' - INTEGER :: error - - ! Create file for visiting - CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error) - - ! Create group - CALL H5Gcreate_f(fid, "/Group1", gid, error) - - ! Create nested group - CALL H5Gcreate_f(gid, "Group2", gid2, error) - - ! Close groups - CALL h5gclose_f(gid2, error) - CALL h5gclose_f(gid, error) - - ! Create soft links to groups created - CALL H5Lcreate_soft_f("/Group1", fid, "/soft_one", error) - CALL H5Lcreate_soft_f("/Group1/Group2", fid, "/soft_two", error) - - ! Create dangling soft link - CALL H5Lcreate_soft_f("nowhere", fid, "/soft_dangle", error) - - ! Create hard links to all groups - CALL H5Lcreate_hard_f(fid, "/", fid, "hard_zero", error) - CALL H5Lcreate_hard_f(fid, "/Group1", fid, "hard_one", error) - CALL H5Lcreate_hard_f(fid, "/Group1/Group2", fid, "hard_two", error) - - ! Create loops w/hard links - CALL H5Lcreate_hard_f(fid, "/Group1", fid, "/Group1/hard_one", error) - CALL H5Lcreate_hard_f(fid, "/", fid, "/Group1/Group2/hard_zero", error) - - ! Create dataset in each group - CALL H5Screate_f(H5S_SCALAR_F, sid, error) - - CALL H5Dcreate_f(fid, "/Dataset_zero", H5T_NATIVE_INTEGER, sid, did, error) - CALL H5Dclose_f(did, error) - - CALL H5Dcreate_f(fid, "/Group1/Dataset_one", H5T_NATIVE_INTEGER, sid, did, error) - CALL H5Dclose_f(did, error) - - CALL H5Dcreate_f(fid, "/Group1/Group2/Dataset_two", H5T_NATIVE_INTEGER, sid, did, error) - CALL H5Dclose_f(did, error) - - CALL H5Sclose_f(sid, error) - - ! Create named datatype in each group - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) - - CALL H5Tcommit_f(fid, "/Type_zero", tid, error) - CALL H5Tclose_f(tid, error) - - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) - CALL H5Tcommit_f(fid, "/Group1/Type_one", tid, error) - CALL H5Tclose_f(tid, error) - - CALL H5Tcopy_f(H5T_NATIVE_INTEGER, tid, error) - CALL H5Tcommit_f(fid, "/Group1/Group2/Type_two", tid, error) - CALL H5Tclose_f(tid, error) - -END SUBROUTINE build_visit_file - -END MODULE TH5O_F03 diff --git a/fortran/test/tH5P.F90 b/fortran/test/tH5P.F90 new file mode 100644 index 0000000..39d8c1e --- /dev/null +++ b/fortran/test/tH5P.F90 @@ -0,0 +1,677 @@ +!****h* root/fortran/test/tH5P.f90 +! +! NAME +! tH5P.f90 +! +! FUNCTION +! Basic testing of Fortran H5P APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! external_test, multi_file_test +! +!***** +MODULE TH5P + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +SUBROUTINE external_test(cleanup, total_error) + +! This subroutine tests following functionalities: +! h5pset_external_f, h5pget_external_count_f, +! h5pget_external_f + + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=8), PARAMETER :: filename = "external" + CHARACTER(LEN=80) :: fix_filename + INTEGER(HID_T) :: file_id + INTEGER(HID_T) :: plist_id + INTEGER(HID_T) :: space_id + INTEGER(HID_T) :: dataset_id + INTEGER(HSIZE_T), DIMENSION(1) :: cur_size !data space current size + INTEGER(HSIZE_T), DIMENSION(1) :: max_size !data space maximum size + CHARACTER(LEN=256) :: name !external file name + INTEGER(OFF_T) :: file_offset !external file offset + INTEGER(HSIZE_T) :: file_size !sizeof external file segment + INTEGER :: error !error code + INTEGER(SIZE_T) :: int_size !size of integer + INTEGER(HSIZE_T) :: file_bytes !Number of bytes reserved + !in the file for the data + INTEGER :: RANK = 1 !dataset rank + INTEGER :: count !number of external files for the + !specified dataset + INTEGER(SIZE_T) :: namesize + INTEGER(HSIZE_T) :: size, buf_size + INTEGER :: idx + + buf_size = 4*1024*1024 + + ! + !Create file "external.h5" using default properties. + ! + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + STOP "Cannot modify filename" + ENDIF + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + CALL h5pcreate_f(H5P_DATASET_XFER_F, plist_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_buffer_f(plist_id, buf_size, error) + CALL check("h5pset_buffer_f", error, total_error) + CALL h5pget_buffer_f(plist_id, size, error) + CALL check("h5pget_buffer_f", error, total_error) + IF (size .NE.buf_size) THEN + total_error = total_error + 1 + WRITE(*,*) "h5pget_buffer_f returned wrong size, error" + ENDIF + CALL h5pclose_f(plist_id, error) + CALL check("h5pclose_f", error, total_error) + + CALL h5pcreate_f(H5P_DATASET_CREATE_F, plist_id, error) + CALL check("h5pcreate_f",error,total_error) + cur_size(1) =100 + max_size(1) = 100 + CALL h5tget_size_f(H5T_NATIVE_INTEGER, int_size, error) + CALL check("h5tget_size_f",error,total_error) + file_size = int_size * max_size(1) + CALL h5pset_external_f(plist_id, "ext1.data", INT(0,off_t), file_size, error) + CALL check("h5pset_external_f",error,total_error) + CALL h5screate_simple_f(RANK, cur_size, space_id, error, max_size) + CALL check("h5screate_simple_f", error, total_error) + CALL h5dcreate_f(file_id, "dset1", H5T_NATIVE_INTEGER, space_id, & + dataset_id, error, plist_id) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dclose_f(dataset_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5pclose_f(plist_id, error) + CALL check("h5pclose_f", error, total_error) + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5fclose_f(file_id, error) + + CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL h5dopen_f(file_id, "dset1", dataset_id, error) + CALL check("h5dopen_f",error,total_error) + + ! Read dataset creation information + CALL h5dget_create_plist_f(dataset_id, plist_id, error) + CALL check("h5dget_create_plist_f",error,total_error) + CALL h5pget_external_count_f(plist_id, count, error) + CALL check("h5pget_external_count_f",error,total_error) + IF(count .NE. 1 ) THEN + WRITE (*,*) "got external_count is not correct" + total_error = total_error + 1 + END IF + namesize = 10 + idx = 0 + CALL h5pget_external_f(plist_id, idx, namesize, name, file_offset, & + file_bytes, error) + CALL check("h5pget_external_f",error,total_error) + IF(file_offset .NE. 0 ) THEN + WRITE (*,*) "got external file offset is not correct" + total_error = total_error + 1 + END IF + IF(file_bytes .NE. file_size ) THEN + WRITE (*,*) "got external file size is not correct" + total_error = total_error + 1 + END IF + + CALL h5dclose_f(dataset_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5pclose_f(plist_id, error) + CALL check("h5pclose_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 external_test + +SUBROUTINE multi_file_test(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=9), PARAMETER :: filename = "multidset" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name + + 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 ! Datatype identifier + INTEGER(HID_T) :: fapl, fapl_1 ! File access property list identifier + INTEGER, DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_map, memb_map_out + INTEGER(HID_T), DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_fapl, memb_fapl_out + CHARACTER(LEN=20), DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_name, memb_name_out + REAL, DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_addr, memb_addr_out + !INTEGER(HADDR_T), DIMENSION(0:H5FD_MEM_NTYPES_F) :: memb_addr + LOGICAL :: relax = .TRUE. + LOGICAL :: relax_out = .TRUE. + + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions + INTEGER :: rank = 2 ! Dataset rank + + INTEGER, DIMENSION(4,6) :: dset_data, data_out ! Data buffers + INTEGER :: error ! Error flag + INTEGER(HID_T) :: driver + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + INTEGER :: mdc_nelmts + INTEGER(SIZE_T) :: rdcc_nelmts + INTEGER(SIZE_T) :: rdcc_nbytes + REAL :: rdcc_w0 + memb_fapl = H5P_DEFAULT_F + memb_map = H5FD_MEM_SUPER_F + memb_addr = 0. + memb_map(H5FD_MEM_SUPER_F) = H5FD_MEM_SUPER_F + memb_addr(H5FD_MEM_SUPER_F) = 0. + memb_map(H5FD_MEM_BTREE_F) = H5FD_MEM_BTREE_F + memb_addr(H5FD_MEM_BTREE_F) = 0.1 + memb_map(H5FD_MEM_DRAW_F) = H5FD_MEM_DRAW_F + memb_addr(H5FD_MEM_DRAW_F) = 0.5 + memb_map(H5FD_MEM_GHEAP_F) = H5FD_MEM_GHEAP_F + memb_addr(H5FD_MEM_GHEAP_F) = 0.2 + memb_map(H5FD_MEM_LHEAP_F) = H5FD_MEM_LHEAP_F + memb_addr(H5FD_MEM_LHEAP_F) = 0.3 + memb_map(H5FD_MEM_OHDR_F) = H5FD_MEM_OHDR_F + memb_addr(H5FD_MEM_OHDR_F) = 0.4 + + memb_name = ' ' + memb_name(H5FD_MEM_SUPER_F) = '%s-s.h5' + memb_name(H5FD_MEM_BTREE_F) = '%s-b.h5' + memb_name(H5FD_MEM_DRAW_F) = '%s-r.h5' + memb_name(H5FD_MEM_GHEAP_F) = '%s-g.h5' + memb_name(H5FD_MEM_LHEAP_F) = '%s-l.h5' + memb_name(H5FD_MEM_OHDR_F) = '%s-o.h5' + + ! + ! Initialize the dset_data array. + ! + DO i = 1, 4 + DO j = 1, 6 + dset_data(i,j) = (i-1)*6 + j + END DO + END DO + + ! + ! 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" + STOP + ENDIF + CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_fapl_multi_f(fapl, memb_map, memb_fapl, memb_name, memb_addr, relax, error) + CALL check("h5pset_fapl_multi_f", error, total_error) + CALL h5pget_fapl_multi_f(fapl, memb_map_out, memb_fapl_out, memb_name_out, & + memb_addr_out, relax_out, error) + CALL check("h5pget_fapl_multi_f", error, total_error) + CALL h5pget_driver_f(fapl, driver, error) + CALL check("h5pget_driver_f",error, total_error) + IF(driver .NE. H5FD_MULTI_F) THEN + WRITE(*,*) "Wrong value for driver" + ENDIF + ! + ! Let's check h5pget(set)cache_f APIs here for now + ! + CALL h5pget_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, & + rdcc_w0, error) + CALL check("h5pget_cache_f", error, total_error) + + ! + ! Set cache to some number + ! + rdcc_nbytes = 1024*1024 + CALL h5pset_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, & + rdcc_w0, error) + CALL check("h5pset_cache_f", error, total_error) + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error, access_prp = fapl) + CALL check("h5fcreate_f", error, total_error) + IF(error .NE. 0) THEN + WRITE(*,*) "Cannot create file using multi-file driver... Exiting...." + total_error = 1 + CALL h5pclose_f(fapl, error) + RETURN + ENDIF + ! + ! Create the dataspace. + ! + CALL h5screate_simple_f(rank, dims, dspace_id, error) + CALL check("h5screate_simple_f", error, total_error) + ! + ! Create the dataset with default properties. + ! + CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + ! + ! Write the dataset. + ! + data_dims(1) = 4 + data_dims(2) = 6 + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) + 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) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + CALL h5pclose_f(fapl, error) + CALL check("h5pclose_f", error, total_error) + ! + ! Open the existing file. + ! + CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_fapl_multi_f(fapl, memb_map, memb_fapl, memb_name, memb_addr, relax, error) + CALL check("h5pset_fapl_multi_f", error, total_error) + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error, access_prp = fapl) + CALL check("h5fopen_f", error, total_error) + ! + CALL h5fget_access_plist_f(file_id, fapl_1, error) + CALL check("h5fget_access_plist_f", error, total_error) + !It doesn't work on Windows. + !CALL h5pget_fapl_multi_f(fapl_1, memb_map_out, memb_fapl_out, memb_name_out, & + ! memb_addr_out, relax_out, error) + ! write(*,*) memb_map_out + ! write(*,*) memb_fapl_out + ! write(*,*) memb_name_out + ! write(*,*) memb_addr_out + ! CALL check("h5pget_fapl_multi_f", error, total_error) + + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + + ! + ! Get the dataset type. + ! + CALL h5dget_type_f(dset_id, dtype_id, error) + CALL check("h5dget_type_f", error, total_error) + + ! + ! Get the data space. + ! + CALL h5dget_space_f(dset_id, dspace_id, error) + CALL check("h5dget_space_f", error, total_error) + + ! + ! 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, 4 + DO j = 1, 6 + IF (data_out(i,j) .NE. dset_data(i, j)) THEN + WRITE(*, *) "dataset test error occured" + WRITE(*,*) "data read is not the same as the data writen" + END IF + END DO + END DO + + ! + ! 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 data type. + ! + CALL h5tclose_f(dtype_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) + CALL h5pclose_f(fapl, error) + CALL check("h5pclose_f", error, total_error) + CALL h5pclose_f(fapl_1, 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) + + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-b', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-g', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-l', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-o', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-r', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + IF(cleanup) CALL h5_cleanup_f(filename//'.h5-s', H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + + RETURN +END SUBROUTINE multi_file_test + +!------------------------------------------------------------------------- +! Function: test_chunk_cache +! +! Purpose: Tests APIs: +! H5P_H5PSET_CHUNK_CACHE_F +! H5P_H5PGET_CHUNK_CACHE_F +! H5D_H5DGET_ACCESS_PLIST_F +! +! Return: Success: 0 +! Failure: -1 +! +! C Programmer: Neil Fortner +! Wednesday, October 29, 2008 +! +! FORTRAN Programmer: M. Scot Breitenfeld +! April 16, 2009 +!------------------------------------------------------------------------- +! +SUBROUTINE test_chunk_cache(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=14), PARAMETER :: filename="chunk_cache" + CHARACTER(LEN=80) :: fix_filename + INTEGER(hid_t) :: fid = -1 ! File ID + INTEGER(hid_t) :: fapl_local = -1 ! Local fapl + INTEGER(hid_t) :: fapl_def = -1 ! Default fapl + INTEGER(hid_t) :: dcpl = -1 ! Dataset creation property list ID + INTEGER(hid_t) :: dapl1 = -1 ! Dataset access property list ID + INTEGER(hid_t) :: dapl2 = -1 ! Dataset access property list ID + INTEGER(hid_t) :: sid = -1 ! Dataspace ID + INTEGER(hid_t) :: dsid = -1 ! Dataset ID + INTEGER(hsize_t), DIMENSION(1:1) :: chunk_dim, NDIM = (/100/) ! Dataset and chunk dimensions + INTEGER(size_t) :: nslots_1, nslots_2, nslots_3, nslots_4 ! rdcc number of elements + INTEGER(size_t) :: nbytes_1, nbytes_2, nbytes_3, nbytes_4 ! rdcc number of bytes + INTEGER :: mdc_nelmts + INTEGER(size_t) ::nlinks ! Number of link traversals + REAL :: w0_1, w0_2, w0_3, w0_4 ! rdcc preemption policy + INTEGER :: error + INTEGER(size_t) rdcc_nelmts + INTEGER(size_t) rdcc_nbytes + REAL :: rdcc_w0 + + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + WRITE(*,*) "Cannot modify filename" + STOP + ENDIF + + ! Create a default fapl and dapl + CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl_def, error) + CALL check("H5Pcreate_f", error, total_error) + CALL H5Pcreate_f(H5P_DATASET_ACCESS_F, dapl1, error) + CALL check("H5Pcreate_f", error, total_error) + + ! Verify that H5Pget_chunk_cache(dapl) returns the same values as are in + ! the default fapl. + ! + CALL H5Pget_cache_f(fapl_def, mdc_nelmts, nslots_1, nbytes_1, w0_1, error) + CALL check("H5Pget_cache_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl1, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", nslots_1, nslots_4, total_error) + CALL verify("H5Pget_chunk_cache_f", nbytes_1, nbytes_4, total_error) + CALL verify("H5Pget_chunk_cache_f", w0_1, w0_4, total_error) + + ! Set a lapl property on dapl1 (to verify inheritance) + CALL H5Pset_nlinks_f(dapl1, 134_size_t , error) + CALL check("H5Pset_nlinks_f", error, total_error) + CALL H5Pget_nlinks_f(dapl1, nlinks, error) + CALL check("H5Pget_nlinks_f", error, total_error) + CALL verify("H5Pget_nlinks_f", INT(nlinks), 134, total_error) + + + CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl_local, error) + CALL check("h5pcreate_f", error, total_error) + ! Turn off the chunk cache, so all the chunks are immediately written to disk + CALL H5Pget_cache_f(fapl_local, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, rdcc_w0, error) + CALL check("H5Pget_cache_f", error, total_error) + rdcc_nbytes = 0 + CALL H5Pset_cache_f(fapl_local, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, rdcc_w0, error) + CALL check("H5Pset_cache_f", error, total_error) + + ! Set new rdcc settings on fapl! + nslots_2 = nslots_1 * 2 + nbytes_2 = nbytes_1 * 2 + w0_2 = w0_1 / 2. + + CALL H5Pset_cache_f(fapl_local, 0, nslots_2, nbytes_2, w0_2, error) + CALL check("H5Pset_cache_f", error, total_error) + + ! Create file + CALL H5Fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error, H5P_DEFAULT_F, fapl_local) + CALL check("H5Fcreate_f", error, total_error) + + ! Create dataset creation property list + CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) + CALL check("H5Pcreate_f", error, total_error) + + ! Set chunking + chunk_dim(1) = 10 + CALL H5Pset_chunk_f(dcpl, 1, chunk_dim, error) + CALL check("H5Pset_chunk_f", error, total_error) + + ! Create 1-D dataspace + ndim(1) = 100 + CALL H5Screate_simple_f(1, ndim, sid, error) + CALL check("H5Pcreate_f", error, total_error) + + ! Create dataset with default dapl + CALL H5Dcreate_f(fid, "dset", H5T_NATIVE_INTEGER, sid, dsid, error, dcpl, H5P_DEFAULT_F, dapl1) + CALL check("H5Pcreate_f", error, total_error) + + ! Retrieve dapl from dataset, verify cache values are the same as on fapl_local + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) + + ! Set new values on dapl1. nbytes will be set to default, so the file + ! property will override this setting + + nslots_3 = nslots_2 * 2 + nbytes_3 = H5D_CHUNK_CACHE_NBYTES_DFLT_F + w0_3 = w0_2 / 2 + + CALL H5Pset_chunk_cache_f(dapl1, nslots_3, nbytes_3, w0_3, error) + CALL check("H5Pset_chunk_cache_f", error, total_error) + + ! Close dataset, reopen with dapl1. Note the use of a dapl with H5Oopen + CALL H5Dclose_f(dsid, error) + CALL H5Oopen_f(fid, "dset", dsid, error, dapl1) + + ! Retrieve dapl from dataset, verfiy cache values are the same as on dapl1 + ! + ! Note we rely on the knowledge that H5Pget_chunk_cache retrieves these + ! values directly from the dataset structure, and not from a copy of the + ! dapl used to open the dataset (which is not preserved). + ! + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_3, w0_4, total_error) + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) + + ! Close dataset, reopen with H5P_DEFAULT as dapl + CALL H5Dclose_f(dsid, error) + CALL check("H5Dclose_f", error, total_error) + CALL H5Oopen_f(fid, "dset", dsid, error) + CALL check("H5Oopen_f", error, total_error) + + ! Retrieve dapl from dataset, verfiy cache values are the same as on fapl_local + + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) + + ! Similary, test use of H5Dcreate2 with H5P_DEFAULT + CALL H5Dclose_f(dsid, error) + CALL check("H5Dclose_f", error, total_error) + + CALL H5Dcreate_f(fid, "dset2", H5T_NATIVE_INTEGER, sid, dsid, error, dcpl, H5P_DEFAULT_F, H5P_DEFAULT_F) + CALL check("H5Pcreate_f", error, total_error) + + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) + ! Don't close dapl2, we will use it in the next section + + ! Modify cache values on fapl_local + nbytes_3 = nbytes_2 * 2 + + CALL H5Pset_cache_f(fapl_local, 0, nslots_3, nbytes_3, w0_3, error) + CALL check("H5Pset_cache_f", error, total_error) + + ! Close and reopen file with new fapl_local + + CALL H5Dclose_f(dsid, error) + CALL check("H5Dclose_f", error, total_error) + CALL H5Fclose_f(fid,error) + CALL check("h5fclose_f", error, total_error) + + CALL H5Fopen_f (fix_filename, H5F_ACC_RDWR_F, fid, error, fapl_local) + CALL check("h5fopen_f", error, total_error) + + ! Verify that dapl2 retrieved earlier (using values from the old fapl) + ! sets its values in the new file (test use of H5Dopen2 with a dapl) + ! + + CALL h5dopen_f (fid, "dset", dsid, error, dapl2) + CALL check("h5dopen_f", error, total_error) + + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) ! Close dapl2, to avoid id leak + + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) + + ! Test H5D_CHUNK_CACHE_NSLOTS_DEFAULT and H5D_CHUNK_CACHE_W0_DEFAULT + nslots_2 = H5D_CHUNK_CACHE_NSLOTS_DFLT_F + w0_2 = H5D_CHUNK_CACHE_W0_DFLT_F + + CALL H5Pset_chunk_cache_f(dapl2, nslots_2, nbytes_2, w0_2, error) + CALL check("H5Pset_chunk_cache_f", error, total_error) + + CALL H5Dclose_f(dsid, error) + CALL check("H5Dclose_f", error, total_error) + CALL h5dopen_f (fid, "dset", dsid, error, dapl2) + CALL check("h5dopen_f", error, total_error) + + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) + + CALL H5Dget_access_plist_f(dsid, dapl2, error) + CALL check("H5Dget_access_plist_f", error, total_error) + CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) + CALL check("H5Pget_chunk_cache_f", error, total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) + CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) + CALL verify("H5Pget_chunk_cache_f", w0_3, w0_4, total_error) + +! Close + + CALL H5Dclose_f(dsid, error) + CALL check("H5Dclose_f", error, total_error) + CALL H5Sclose_f(sid,error) + CALL check("H5Sclose_f", error, total_error) + CALL H5Pclose_f(fapl_local,error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(fapl_def,error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(dapl1,error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(dapl2,error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Pclose_f(dcpl,error) + CALL check("H5Pclose_f", error, total_error) + CALL H5Fclose_f(fid,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_chunk_cache + +END MODULE TH5P diff --git a/fortran/test/tH5P.f90 b/fortran/test/tH5P.f90 deleted file mode 100644 index 39d8c1e..0000000 --- a/fortran/test/tH5P.f90 +++ /dev/null @@ -1,677 +0,0 @@ -!****h* root/fortran/test/tH5P.f90 -! -! NAME -! tH5P.f90 -! -! FUNCTION -! Basic testing of Fortran H5P APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! external_test, multi_file_test -! -!***** -MODULE TH5P - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -SUBROUTINE external_test(cleanup, total_error) - -! This subroutine tests following functionalities: -! h5pset_external_f, h5pget_external_count_f, -! h5pget_external_f - - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=8), PARAMETER :: filename = "external" - CHARACTER(LEN=80) :: fix_filename - INTEGER(HID_T) :: file_id - INTEGER(HID_T) :: plist_id - INTEGER(HID_T) :: space_id - INTEGER(HID_T) :: dataset_id - INTEGER(HSIZE_T), DIMENSION(1) :: cur_size !data space current size - INTEGER(HSIZE_T), DIMENSION(1) :: max_size !data space maximum size - CHARACTER(LEN=256) :: name !external file name - INTEGER(OFF_T) :: file_offset !external file offset - INTEGER(HSIZE_T) :: file_size !sizeof external file segment - INTEGER :: error !error code - INTEGER(SIZE_T) :: int_size !size of integer - INTEGER(HSIZE_T) :: file_bytes !Number of bytes reserved - !in the file for the data - INTEGER :: RANK = 1 !dataset rank - INTEGER :: count !number of external files for the - !specified dataset - INTEGER(SIZE_T) :: namesize - INTEGER(HSIZE_T) :: size, buf_size - INTEGER :: idx - - buf_size = 4*1024*1024 - - ! - !Create file "external.h5" using default properties. - ! - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - IF (error .NE. 0) THEN - STOP "Cannot modify filename" - ENDIF - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - CALL h5pcreate_f(H5P_DATASET_XFER_F, plist_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_buffer_f(plist_id, buf_size, error) - CALL check("h5pset_buffer_f", error, total_error) - CALL h5pget_buffer_f(plist_id, size, error) - CALL check("h5pget_buffer_f", error, total_error) - IF (size .NE.buf_size) THEN - total_error = total_error + 1 - WRITE(*,*) "h5pget_buffer_f returned wrong size, error" - ENDIF - CALL h5pclose_f(plist_id, error) - CALL check("h5pclose_f", error, total_error) - - CALL h5pcreate_f(H5P_DATASET_CREATE_F, plist_id, error) - CALL check("h5pcreate_f",error,total_error) - cur_size(1) =100 - max_size(1) = 100 - CALL h5tget_size_f(H5T_NATIVE_INTEGER, int_size, error) - CALL check("h5tget_size_f",error,total_error) - file_size = int_size * max_size(1) - CALL h5pset_external_f(plist_id, "ext1.data", INT(0,off_t), file_size, error) - CALL check("h5pset_external_f",error,total_error) - CALL h5screate_simple_f(RANK, cur_size, space_id, error, max_size) - CALL check("h5screate_simple_f", error, total_error) - CALL h5dcreate_f(file_id, "dset1", H5T_NATIVE_INTEGER, space_id, & - dataset_id, error, plist_id) - CALL check("h5dcreate_f", error, total_error) - - CALL h5dclose_f(dataset_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5pclose_f(plist_id, error) - CALL check("h5pclose_f", error, total_error) - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5fclose_f(file_id, error) - - CALL h5fopen_f(fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL h5dopen_f(file_id, "dset1", dataset_id, error) - CALL check("h5dopen_f",error,total_error) - - ! Read dataset creation information - CALL h5dget_create_plist_f(dataset_id, plist_id, error) - CALL check("h5dget_create_plist_f",error,total_error) - CALL h5pget_external_count_f(plist_id, count, error) - CALL check("h5pget_external_count_f",error,total_error) - IF(count .NE. 1 ) THEN - WRITE (*,*) "got external_count is not correct" - total_error = total_error + 1 - END IF - namesize = 10 - idx = 0 - CALL h5pget_external_f(plist_id, idx, namesize, name, file_offset, & - file_bytes, error) - CALL check("h5pget_external_f",error,total_error) - IF(file_offset .NE. 0 ) THEN - WRITE (*,*) "got external file offset is not correct" - total_error = total_error + 1 - END IF - IF(file_bytes .NE. file_size ) THEN - WRITE (*,*) "got external file size is not correct" - total_error = total_error + 1 - END IF - - CALL h5dclose_f(dataset_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5pclose_f(plist_id, error) - CALL check("h5pclose_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 external_test - -SUBROUTINE multi_file_test(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=9), PARAMETER :: filename = "multidset" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name - - 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 ! Datatype identifier - INTEGER(HID_T) :: fapl, fapl_1 ! File access property list identifier - INTEGER, DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_map, memb_map_out - INTEGER(HID_T), DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_fapl, memb_fapl_out - CHARACTER(LEN=20), DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_name, memb_name_out - REAL, DIMENSION(0:H5FD_MEM_NTYPES_F-1) :: memb_addr, memb_addr_out - !INTEGER(HADDR_T), DIMENSION(0:H5FD_MEM_NTYPES_F) :: memb_addr - LOGICAL :: relax = .TRUE. - LOGICAL :: relax_out = .TRUE. - - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions - INTEGER :: rank = 2 ! Dataset rank - - INTEGER, DIMENSION(4,6) :: dset_data, data_out ! Data buffers - INTEGER :: error ! Error flag - INTEGER(HID_T) :: driver - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - INTEGER :: mdc_nelmts - INTEGER(SIZE_T) :: rdcc_nelmts - INTEGER(SIZE_T) :: rdcc_nbytes - REAL :: rdcc_w0 - memb_fapl = H5P_DEFAULT_F - memb_map = H5FD_MEM_SUPER_F - memb_addr = 0. - memb_map(H5FD_MEM_SUPER_F) = H5FD_MEM_SUPER_F - memb_addr(H5FD_MEM_SUPER_F) = 0. - memb_map(H5FD_MEM_BTREE_F) = H5FD_MEM_BTREE_F - memb_addr(H5FD_MEM_BTREE_F) = 0.1 - memb_map(H5FD_MEM_DRAW_F) = H5FD_MEM_DRAW_F - memb_addr(H5FD_MEM_DRAW_F) = 0.5 - memb_map(H5FD_MEM_GHEAP_F) = H5FD_MEM_GHEAP_F - memb_addr(H5FD_MEM_GHEAP_F) = 0.2 - memb_map(H5FD_MEM_LHEAP_F) = H5FD_MEM_LHEAP_F - memb_addr(H5FD_MEM_LHEAP_F) = 0.3 - memb_map(H5FD_MEM_OHDR_F) = H5FD_MEM_OHDR_F - memb_addr(H5FD_MEM_OHDR_F) = 0.4 - - memb_name = ' ' - memb_name(H5FD_MEM_SUPER_F) = '%s-s.h5' - memb_name(H5FD_MEM_BTREE_F) = '%s-b.h5' - memb_name(H5FD_MEM_DRAW_F) = '%s-r.h5' - memb_name(H5FD_MEM_GHEAP_F) = '%s-g.h5' - memb_name(H5FD_MEM_LHEAP_F) = '%s-l.h5' - memb_name(H5FD_MEM_OHDR_F) = '%s-o.h5' - - ! - ! Initialize the dset_data array. - ! - DO i = 1, 4 - DO j = 1, 6 - dset_data(i,j) = (i-1)*6 + j - END DO - END DO - - ! - ! 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" - STOP - ENDIF - CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_fapl_multi_f(fapl, memb_map, memb_fapl, memb_name, memb_addr, relax, error) - CALL check("h5pset_fapl_multi_f", error, total_error) - CALL h5pget_fapl_multi_f(fapl, memb_map_out, memb_fapl_out, memb_name_out, & - memb_addr_out, relax_out, error) - CALL check("h5pget_fapl_multi_f", error, total_error) - CALL h5pget_driver_f(fapl, driver, error) - CALL check("h5pget_driver_f",error, total_error) - IF(driver .NE. H5FD_MULTI_F) THEN - WRITE(*,*) "Wrong value for driver" - ENDIF - ! - ! Let's check h5pget(set)cache_f APIs here for now - ! - CALL h5pget_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, & - rdcc_w0, error) - CALL check("h5pget_cache_f", error, total_error) - - ! - ! Set cache to some number - ! - rdcc_nbytes = 1024*1024 - CALL h5pset_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, & - rdcc_w0, error) - CALL check("h5pset_cache_f", error, total_error) - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error, access_prp = fapl) - CALL check("h5fcreate_f", error, total_error) - IF(error .NE. 0) THEN - WRITE(*,*) "Cannot create file using multi-file driver... Exiting...." - total_error = 1 - CALL h5pclose_f(fapl, error) - RETURN - ENDIF - ! - ! Create the dataspace. - ! - CALL h5screate_simple_f(rank, dims, dspace_id, error) - CALL check("h5screate_simple_f", error, total_error) - ! - ! Create the dataset with default properties. - ! - CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f", error, total_error) - ! - ! Write the dataset. - ! - data_dims(1) = 4 - data_dims(2) = 6 - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) - 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) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - CALL h5pclose_f(fapl, error) - CALL check("h5pclose_f", error, total_error) - ! - ! Open the existing file. - ! - CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_fapl_multi_f(fapl, memb_map, memb_fapl, memb_name, memb_addr, relax, error) - CALL check("h5pset_fapl_multi_f", error, total_error) - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error, access_prp = fapl) - CALL check("h5fopen_f", error, total_error) - ! - CALL h5fget_access_plist_f(file_id, fapl_1, error) - CALL check("h5fget_access_plist_f", error, total_error) - !It doesn't work on Windows. - !CALL h5pget_fapl_multi_f(fapl_1, memb_map_out, memb_fapl_out, memb_name_out, & - ! memb_addr_out, relax_out, error) - ! write(*,*) memb_map_out - ! write(*,*) memb_fapl_out - ! write(*,*) memb_name_out - ! write(*,*) memb_addr_out - ! CALL check("h5pget_fapl_multi_f", error, total_error) - - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - - ! - ! Get the dataset type. - ! - CALL h5dget_type_f(dset_id, dtype_id, error) - CALL check("h5dget_type_f", error, total_error) - - ! - ! Get the data space. - ! - CALL h5dget_space_f(dset_id, dspace_id, error) - CALL check("h5dget_space_f", error, total_error) - - ! - ! 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, 4 - DO j = 1, 6 - IF (data_out(i,j) .NE. dset_data(i, j)) THEN - WRITE(*, *) "dataset test error occured" - WRITE(*,*) "data read is not the same as the data writen" - END IF - END DO - END DO - - ! - ! 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 data type. - ! - CALL h5tclose_f(dtype_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) - CALL h5pclose_f(fapl, error) - CALL check("h5pclose_f", error, total_error) - CALL h5pclose_f(fapl_1, 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) - - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-b', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-g', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-l', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-o', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-r', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - IF(cleanup) CALL h5_cleanup_f(filename//'.h5-s', H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - - RETURN -END SUBROUTINE multi_file_test - -!------------------------------------------------------------------------- -! Function: test_chunk_cache -! -! Purpose: Tests APIs: -! H5P_H5PSET_CHUNK_CACHE_F -! H5P_H5PGET_CHUNK_CACHE_F -! H5D_H5DGET_ACCESS_PLIST_F -! -! Return: Success: 0 -! Failure: -1 -! -! C Programmer: Neil Fortner -! Wednesday, October 29, 2008 -! -! FORTRAN Programmer: M. Scot Breitenfeld -! April 16, 2009 -!------------------------------------------------------------------------- -! -SUBROUTINE test_chunk_cache(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=14), PARAMETER :: filename="chunk_cache" - CHARACTER(LEN=80) :: fix_filename - INTEGER(hid_t) :: fid = -1 ! File ID - INTEGER(hid_t) :: fapl_local = -1 ! Local fapl - INTEGER(hid_t) :: fapl_def = -1 ! Default fapl - INTEGER(hid_t) :: dcpl = -1 ! Dataset creation property list ID - INTEGER(hid_t) :: dapl1 = -1 ! Dataset access property list ID - INTEGER(hid_t) :: dapl2 = -1 ! Dataset access property list ID - INTEGER(hid_t) :: sid = -1 ! Dataspace ID - INTEGER(hid_t) :: dsid = -1 ! Dataset ID - INTEGER(hsize_t), DIMENSION(1:1) :: chunk_dim, NDIM = (/100/) ! Dataset and chunk dimensions - INTEGER(size_t) :: nslots_1, nslots_2, nslots_3, nslots_4 ! rdcc number of elements - INTEGER(size_t) :: nbytes_1, nbytes_2, nbytes_3, nbytes_4 ! rdcc number of bytes - INTEGER :: mdc_nelmts - INTEGER(size_t) ::nlinks ! Number of link traversals - REAL :: w0_1, w0_2, w0_3, w0_4 ! rdcc preemption policy - INTEGER :: error - INTEGER(size_t) rdcc_nelmts - INTEGER(size_t) rdcc_nbytes - REAL :: rdcc_w0 - - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - IF (error .NE. 0) THEN - WRITE(*,*) "Cannot modify filename" - STOP - ENDIF - - ! Create a default fapl and dapl - CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl_def, error) - CALL check("H5Pcreate_f", error, total_error) - CALL H5Pcreate_f(H5P_DATASET_ACCESS_F, dapl1, error) - CALL check("H5Pcreate_f", error, total_error) - - ! Verify that H5Pget_chunk_cache(dapl) returns the same values as are in - ! the default fapl. - ! - CALL H5Pget_cache_f(fapl_def, mdc_nelmts, nslots_1, nbytes_1, w0_1, error) - CALL check("H5Pget_cache_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl1, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", nslots_1, nslots_4, total_error) - CALL verify("H5Pget_chunk_cache_f", nbytes_1, nbytes_4, total_error) - CALL verify("H5Pget_chunk_cache_f", w0_1, w0_4, total_error) - - ! Set a lapl property on dapl1 (to verify inheritance) - CALL H5Pset_nlinks_f(dapl1, 134_size_t , error) - CALL check("H5Pset_nlinks_f", error, total_error) - CALL H5Pget_nlinks_f(dapl1, nlinks, error) - CALL check("H5Pget_nlinks_f", error, total_error) - CALL verify("H5Pget_nlinks_f", INT(nlinks), 134, total_error) - - - CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl_local, error) - CALL check("h5pcreate_f", error, total_error) - ! Turn off the chunk cache, so all the chunks are immediately written to disk - CALL H5Pget_cache_f(fapl_local, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, rdcc_w0, error) - CALL check("H5Pget_cache_f", error, total_error) - rdcc_nbytes = 0 - CALL H5Pset_cache_f(fapl_local, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, rdcc_w0, error) - CALL check("H5Pset_cache_f", error, total_error) - - ! Set new rdcc settings on fapl! - nslots_2 = nslots_1 * 2 - nbytes_2 = nbytes_1 * 2 - w0_2 = w0_1 / 2. - - CALL H5Pset_cache_f(fapl_local, 0, nslots_2, nbytes_2, w0_2, error) - CALL check("H5Pset_cache_f", error, total_error) - - ! Create file - CALL H5Fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid, error, H5P_DEFAULT_F, fapl_local) - CALL check("H5Fcreate_f", error, total_error) - - ! Create dataset creation property list - CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) - CALL check("H5Pcreate_f", error, total_error) - - ! Set chunking - chunk_dim(1) = 10 - CALL H5Pset_chunk_f(dcpl, 1, chunk_dim, error) - CALL check("H5Pset_chunk_f", error, total_error) - - ! Create 1-D dataspace - ndim(1) = 100 - CALL H5Screate_simple_f(1, ndim, sid, error) - CALL check("H5Pcreate_f", error, total_error) - - ! Create dataset with default dapl - CALL H5Dcreate_f(fid, "dset", H5T_NATIVE_INTEGER, sid, dsid, error, dcpl, H5P_DEFAULT_F, dapl1) - CALL check("H5Pcreate_f", error, total_error) - - ! Retrieve dapl from dataset, verify cache values are the same as on fapl_local - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) - - ! Set new values on dapl1. nbytes will be set to default, so the file - ! property will override this setting - - nslots_3 = nslots_2 * 2 - nbytes_3 = H5D_CHUNK_CACHE_NBYTES_DFLT_F - w0_3 = w0_2 / 2 - - CALL H5Pset_chunk_cache_f(dapl1, nslots_3, nbytes_3, w0_3, error) - CALL check("H5Pset_chunk_cache_f", error, total_error) - - ! Close dataset, reopen with dapl1. Note the use of a dapl with H5Oopen - CALL H5Dclose_f(dsid, error) - CALL H5Oopen_f(fid, "dset", dsid, error, dapl1) - - ! Retrieve dapl from dataset, verfiy cache values are the same as on dapl1 - ! - ! Note we rely on the knowledge that H5Pget_chunk_cache retrieves these - ! values directly from the dataset structure, and not from a copy of the - ! dapl used to open the dataset (which is not preserved). - ! - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_3, w0_4, total_error) - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) - - ! Close dataset, reopen with H5P_DEFAULT as dapl - CALL H5Dclose_f(dsid, error) - CALL check("H5Dclose_f", error, total_error) - CALL H5Oopen_f(fid, "dset", dsid, error) - CALL check("H5Oopen_f", error, total_error) - - ! Retrieve dapl from dataset, verfiy cache values are the same as on fapl_local - - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) - - ! Similary, test use of H5Dcreate2 with H5P_DEFAULT - CALL H5Dclose_f(dsid, error) - CALL check("H5Dclose_f", error, total_error) - - CALL H5Dcreate_f(fid, "dset2", H5T_NATIVE_INTEGER, sid, dsid, error, dcpl, H5P_DEFAULT_F, H5P_DEFAULT_F) - CALL check("H5Pcreate_f", error, total_error) - - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) - ! Don't close dapl2, we will use it in the next section - - ! Modify cache values on fapl_local - nbytes_3 = nbytes_2 * 2 - - CALL H5Pset_cache_f(fapl_local, 0, nslots_3, nbytes_3, w0_3, error) - CALL check("H5Pset_cache_f", error, total_error) - - ! Close and reopen file with new fapl_local - - CALL H5Dclose_f(dsid, error) - CALL check("H5Dclose_f", error, total_error) - CALL H5Fclose_f(fid,error) - CALL check("h5fclose_f", error, total_error) - - CALL H5Fopen_f (fix_filename, H5F_ACC_RDWR_F, fid, error, fapl_local) - CALL check("h5fopen_f", error, total_error) - - ! Verify that dapl2 retrieved earlier (using values from the old fapl) - ! sets its values in the new file (test use of H5Dopen2 with a dapl) - ! - - CALL h5dopen_f (fid, "dset", dsid, error, dapl2) - CALL check("h5dopen_f", error, total_error) - - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) ! Close dapl2, to avoid id leak - - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_2, w0_4, total_error) - - ! Test H5D_CHUNK_CACHE_NSLOTS_DEFAULT and H5D_CHUNK_CACHE_W0_DEFAULT - nslots_2 = H5D_CHUNK_CACHE_NSLOTS_DFLT_F - w0_2 = H5D_CHUNK_CACHE_W0_DFLT_F - - CALL H5Pset_chunk_cache_f(dapl2, nslots_2, nbytes_2, w0_2, error) - CALL check("H5Pset_chunk_cache_f", error, total_error) - - CALL H5Dclose_f(dsid, error) - CALL check("H5Dclose_f", error, total_error) - CALL h5dopen_f (fid, "dset", dsid, error, dapl2) - CALL check("h5dopen_f", error, total_error) - - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) - - CALL H5Dget_access_plist_f(dsid, dapl2, error) - CALL check("H5Dget_access_plist_f", error, total_error) - CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error) - CALL check("H5Pget_chunk_cache_f", error, total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) - CALL verify("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL verify("H5Pget_chunk_cache_f", w0_3, w0_4, total_error) - -! Close - - CALL H5Dclose_f(dsid, error) - CALL check("H5Dclose_f", error, total_error) - CALL H5Sclose_f(sid,error) - CALL check("H5Sclose_f", error, total_error) - CALL H5Pclose_f(fapl_local,error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(fapl_def,error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(dapl1,error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(dapl2,error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Pclose_f(dcpl,error) - CALL check("H5Pclose_f", error, total_error) - CALL H5Fclose_f(fid,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_chunk_cache - -END MODULE TH5P diff --git a/fortran/test/tH5P_F03.F90 b/fortran/test/tH5P_F03.F90 new file mode 100644 index 0000000..ec9fef2 --- /dev/null +++ b/fortran/test/tH5P_F03.F90 @@ -0,0 +1,617 @@ +!****h* root/fortran/test/tH5P_F03.f90 +! +! NAME +! tH5P_F03.f90 +! +! FUNCTION +! Test FORTRAN HDF5 H5P 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! USES +! test_genprop_cls_cb1_mod +! +! CONTAINS SUBROUTINES +! test_create, test_genprop_class_callback +! +!***** + +! ***************************************** +! *** H 5 P T E S T S +! ***************************************** +MODULE test_genprop_cls_cb1_mod + + ! Callback subroutine for test_genprop_class_callback + ! and the function H5Pcreate_class_f. + + USE HDF5 + USE ISO_C_BINDING + IMPLICIT NONE + + TYPE, BIND(C) :: cop_cb_struct_ ! Struct for iterations + INTEGER :: count + INTEGER(HID_T) :: id + END TYPE cop_cb_struct_ + +CONTAINS + + INTEGER FUNCTION test_genprop_cls_cb1_f(list_id, create_data ) bind(C) + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN), VALUE :: list_id + + TYPE(cop_cb_struct_) :: create_data + + create_data%count = create_data%count + 1 + create_data%id = list_id + + test_genprop_cls_cb1_f = 0 + + END FUNCTION test_genprop_cls_cb1_f + +END MODULE test_genprop_cls_cb1_mod + +MODULE TH5P_F03 + + USE HDF5 + USE TH5_MISC + USE TH5_MISC_GEN + USE ISO_C_BINDING + +CONTAINS + +!------------------------------------------------------------------------- +! * Function: test_create +! * +! * Purpose: Tests H5Pset_fill_value_f and H5Pget_fill_value_f +! * +! * Return: Success: 0 +! * +! * Failure: number of errors +! * +! * Programmer: M. Scot Breitenfeld +! * June 24, 2008 +! * +! * Modifications: +! * +! *------------------------------------------------------------------------- +! + +SUBROUTINE test_create(total_error) + + IMPLICIT NONE + + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T) :: fapl + + INTEGER(hid_t) :: file=-1, space=-1, dcpl=-1, comp_type_id=-1 + INTEGER(hid_t) :: dset9=-1 + INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: cur_size = (/2, 8, 8, 4, 2/) + INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: ch_size= (/1, 1, 1, 4, 1/) + CHARACTER(LEN=14) :: filename ='test_create.h5' + + TYPE(comp_datatype), TARGET :: rd_c, fill_ctype + INTEGER :: error + INTEGER(SIZE_T) :: h5off + TYPE(C_PTR) :: f_ptr + LOGICAL :: differ1, differ2 + CHARACTER(LEN=1) :: cfill + INTEGER :: ifill + REAL :: rfill + REAL(KIND=dp) :: dpfill + + ! + ! * Create a file. + ! + CALL h5fcreate_f(filename,H5F_ACC_TRUNC_F,file,error) + CALL check("h5fcreate_f", error, total_error) + + CALL h5screate_simple_f(5, cur_size, space, error, cur_size) + CALL check("h5screate_simple_f", error, total_error) + + CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) + CALL check("H5Pcreate_f", error, total_error) + + CALL h5pset_chunk_f(dcpl, 5, ch_size, error) + CALL check("h5pset_chunk_f",error, total_error) + + ! Create a compound datatype + CALL h5tcreate_f(H5T_COMPOUND_F, H5_SIZEOF(fill_ctype), comp_type_id, error) + CALL check("h5tcreate_f", error, total_error) + h5off = H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%a)) + CALL h5tinsert_f(comp_type_id, "a", h5off , H5T_NATIVE_REAL, error) + CALL check("h5tinsert_f", error, total_error) + CALL h5tinsert_f(comp_type_id, "x", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%x)), H5T_NATIVE_INTEGER, error) + CALL check("h5tinsert_f", error, total_error) + CALL h5tinsert_f(comp_type_id, "y", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%y)), H5T_NATIVE_DOUBLE, error) + CALL check("h5tinsert_f", error, total_error) + CALL h5tinsert_f(comp_type_id, "z", & + H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%z)), H5T_NATIVE_CHARACTER, error) + CALL check("h5tinsert_f", error, total_error) + + + CALL H5Pset_alloc_time_f(dcpl, H5D_ALLOC_TIME_LATE_F,error) + CALL check("H5Pset_alloc_time_f",error, total_error) + + CALL H5Pset_fill_time_f(dcpl, H5D_FILL_TIME_ALLOC_F, error) + CALL check("H5Pset_fill_time_f",error, total_error) + + ! Compound datatype test + + f_ptr = C_LOC(fill_ctype) + + CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error) + CALL check("H5Pget_fill_value_f",error, total_error) + + fill_ctype%y = 4444.D0 + fill_ctype%z = 'S' + fill_ctype%a = 5555. + fill_ctype%x = 55 + + f_ptr = C_LOC(fill_ctype) + + ! Test various fill values + CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_CHARACTER, 'X', error) + CALL check("H5Pset_fill_value_f",error, total_error) + CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_CHARACTER, cfill, error) + CALL check("H5Pget_fill_value_f",error, total_error) + IF(cfill.NE.'X')THEN + PRINT*,"***ERROR: Returned wrong fill value (character)" + total_error = total_error + 1 + ENDIF + CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_INTEGER, 9, error) + CALL check("H5Pset_fill_value_f",error, total_error) + CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_INTEGER, ifill, error) + CALL check("H5Pget_fill_value_f",error, total_error) + IF(ifill.NE.9)THEN + PRINT*,"***ERROR: Returned wrong fill value (integer)" + total_error = total_error + 1 + ENDIF + CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_DOUBLE, 1.0_dp, error) + CALL check("H5Pset_fill_value_f",error, total_error) + CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_DOUBLE, dpfill, error) + CALL check("H5Pget_fill_value_f",error, total_error) + CALL VERIFY("***ERROR: Returned wrong fill value (double)", dpfill, 1.0_dp, total_error) + CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_REAL, 2.0, error) + CALL check("H5Pset_fill_value_f",error, total_error) + CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_REAL, rfill, error) + CALL check("H5Pget_fill_value_f",error, total_error) + CALL VERIFY("***ERROR: Returned wrong fill value (real)", rfill, 2.0, total_error) + + ! For the actual compound type + CALL H5Pset_fill_value_f(dcpl, comp_type_id, f_ptr, error) + CALL check("H5Pget_fill_value_f",error, total_error) + + CALL h5dcreate_f(file,"dset9", comp_type_id, space, dset9, error, dcpl_id=dcpl) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dclose_f(dset9, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5fclose_f(file,error) + CALL check("h5fclose_f", error, total_error) + + ! Open the file and get the dataset fill value from each dataset + CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error) + CALL check("H5Pcreate_f",error, total_error) + + CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) + CALL check("H5Pset_libver_bounds_f",error, total_error) + + CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, file, error, fapl) + CALL check("h5fopen_f", error, total_error) + + ! Compound datatype test + CALL h5dopen_f(file, "dset9", dset9, error) + CALL check("h5dopen_f", error, total_error) + + CALL H5Dget_create_plist_f(dset9, dcpl, error) + CALL check("H5Dget_create_plist_f", error, total_error) + + f_ptr = C_LOC(rd_c) + + CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error) + CALL check("H5Pget_fill_value_f", error, total_error) + CALL verify("***ERROR: Returned wrong fill value", rd_c%a, fill_ctype%a, total_error) + CALL verify("***ERROR: Returned wrong fill value", rd_c%y, fill_ctype%y, total_error) + + IF( rd_c%x .NE. fill_ctype%x .OR. & + rd_c%z .NE. fill_ctype%z )THEN + + PRINT*,"***ERROR: Returned wrong fill value" + total_error = total_error + 1 + + ENDIF + + CALL h5dclose_f(dset9, error) + CALL check("h5dclose_f", error, total_error) + + CALL H5Pclose_f(dcpl, error) + CALL check("H5Pclose_f", error, total_error) + + CALL h5fclose_f(file,error) + CALL check("h5fclose_f", error, total_error) + +END SUBROUTINE test_create + + +SUBROUTINE test_genprop_class_callback(total_error) + + ! + ! + ! test_genprop_class_callback(): Test basic generic property list code. + ! Tests callbacks for property lists in a generic class. + ! + ! FORTRAN TESTS: + ! Tests function H5Pcreate_class_f with callback. + ! + ! + + USE test_genprop_cls_cb1_mod + IMPLICIT NONE + + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(hid_t) :: cid1, cid2 ! Generic Property class ID + INTEGER(hid_t) :: lid1, lid2 ! Generic Property list ID + INTEGER(size_t) :: nprops ! Number of properties in class + + TYPE(cop_cb_struct_), TARGET :: crt_cb_struct, cls_cb_struct + INTEGER :: CLASS1_NAME_SIZE = 7 ! length of class string + CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1", CLASS1_NAME_BUF + TYPE(C_FUNPTR) :: f1, f5 + TYPE(C_PTR) :: f2, f6 + + CHARACTER(LEN=10) :: PROP1_NAME = "Property 1" + INTEGER(SIZE_T) :: PROP1_SIZE = 10 + CHARACTER(LEN=10) :: PROP2_NAME = "Property 2" + INTEGER(SIZE_T) :: PROP2_SIZE = 10 + CHARACTER(LEN=10) :: PROP3_NAME = "Property 3" + INTEGER(SIZE_T) :: PROP3_SIZE = 10 + CHARACTER(LEN=10) :: PROP4_NAME = "Property 4" + INTEGER(SIZE_T) :: PROP4_SIZE = 10 + INTEGER :: PROP1_DEF_VALUE = 10 + INTEGER :: PROP2_DEF_VALUE = 10 + INTEGER :: PROP3_DEF_VALUE = 10 + INTEGER :: PROP4_DEF_VALUE = 10 + + INTEGER :: error ! Generic RETURN value + LOGICAL :: flag ! for tests + + f1 = C_FUNLOC(test_genprop_cls_cb1_f) + f5 = C_FUNLOC(test_genprop_cls_cb1_f) + + f2 = C_LOC(crt_cb_struct) + f6 = C_LOC(cls_cb_struct) + + ! Create a new generic class, derived from the root of the class hierarchy + CALL h5pcreate_class_f(h5p_ROOT_F, CLASS1_NAME, cid1, error, f1, f2, c_null_funptr, c_null_ptr, f5, f6) + CALL check("h5pcreate_class_f", error, total_error) + + ! Insert first property into class (with no callbacks) + CALL h5pregister_f(cid1, PROP1_NAME, PROP1_SIZE, PROP1_DEF_VALUE, error) + CALL check("h5pregister_f", error, total_error) + ! Insert second property into class (with no callbacks) + CALL h5pregister_f(cid1, PROP2_NAME, PROP2_SIZE, PROP2_DEF_VALUE, error) + CALL check("h5pregister_f", error, total_error) + ! Insert third property into class (with no callbacks) + CALL h5pregister_f(cid1, PROP3_NAME, PROP3_SIZE, PROP3_DEF_VALUE, error) + CALL check("h5pregister_f", error, total_error) + + ! Insert fourth property into class (with no callbacks) + CALL h5pregister_f(cid1, PROP4_NAME, PROP4_SIZE, PROP4_DEF_VALUE, error) + CALL check("h5pregister_f", error, total_error) + + ! Check the number of properties in class + CALL h5pget_nprops_f(cid1, nprops, error) + CALL check("h5pget_nprops_f", error, total_error) + CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) + + ! Initialize class callback structs + + crt_cb_struct%count = 0 + crt_cb_struct%id = -1 + cls_cb_struct%count = 0 + cls_cb_struct%id = -1 + + ! Create a property list from the class + CALL h5pcreate_f(cid1, lid1, error) + CALL check("h5pcreate_f", error, total_error) + + ! Get the list's class + CALL H5Pget_class_f(lid1, cid2, error) + CALL check("H5Pget_class_f", error, total_error) + + ! Check that the list's class is correct + CALL H5Pequal_f(cid2, cid1, flag, error) + CALL check("H5Pequal_f", error, total_error) + CALL verify("H5Pequal_f", flag, .TRUE., total_error) + + ! Check the class name + CALL H5Pget_class_name_f(cid2, CLASS1_NAME_BUF, CLASS1_NAME_SIZE, error) + CALL check("H5Pget_class_name_f", error, total_error) + CALL verify("H5Pget_class_name_f", CLASS1_NAME_BUF, CLASS1_NAME, error) + IF(error.NE.0)THEN + WRITE(*,*) 'Class names do not match! name=',CLASS1_NAME_BUF, 'CLASS1_NAME=',CLASS1_NAME + total_error = total_error + 1 + ENDIF + ! Close class + CALL h5pclose_class_f(cid2, error) + CALL check("h5pclose_class_f", error, total_error) + + ! Verify that the creation callback occurred + CALL verify("h5pcreate_f", crt_cb_struct%count, 1, total_error) + CALL verify("h5pcreate_f", crt_cb_struct%id, lid1, total_error) + + ! Check the number of properties in list + CALL h5pget_nprops_f(lid1,nprops, error) + CALL check("h5pget_nprops_f", error, total_error) + CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) + + ! Create another property list from the class + CALL h5pcreate_f(cid1, lid2, error) + CALL check("h5pcreate_f", error, total_error) + + ! Verify that the creation callback occurred + CALL verify("h5pcreate_f", crt_cb_struct%count, 2, total_error) + CALL verify("h5pcreate_f", crt_cb_struct%id, lid2, total_error) + + ! Check the number of properties in list + CALL h5pget_nprops_f(lid2,nprops, error) + CALL check("h5pget_nprops_f", error, total_error) + CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) + + ! Close first list + CALL h5pclose_f(lid1, error); + CALL check("h5pclose_f", error, total_error) + + ! Verify that the close callback occurred + CALL verify("h5pcreate_f", cls_cb_struct%count, 1, total_error) + CALL verify("h5pcreate_f", cls_cb_struct%id, lid1, total_error) + + ! Close second list + CALL h5pclose_f(lid2, error); + CALL check("h5pclose_f", error, total_error) + + ! Verify that the close callback occurred + CALL verify("h5pcreate_f", cls_cb_struct%count, 2, total_error) + CALL verify("h5pcreate_f", cls_cb_struct%id, lid2, total_error) + + ! Close class + CALL h5pclose_class_f(cid1, error) + CALL check("h5pclose_class_f", error, total_error) + +END SUBROUTINE test_genprop_class_callback + +!------------------------------------------------------------------------- +! Function: test_h5p_file_image +! +! Purpose: Tests APIs: +! h5pget_file_image_f and h5pset_file_image_f +! +! Return: Success: 0 +! Failure: -1 +! +! FORTRAN Programmer: M. Scot Breitenfeld +! April 1, 2014 +!------------------------------------------------------------------------- + +SUBROUTINE test_h5p_file_image(total_error) + + USE, INTRINSIC :: iso_c_binding + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + INTEGER(hid_t) :: fapl_1 = -1 + INTEGER, PARAMETER :: count = 10 + INTEGER, DIMENSION(1:count), TARGET :: buffer + INTEGER, DIMENSION(1:count), TARGET :: temp + INTEGER :: i + INTEGER(size_t) :: size + INTEGER(size_t) :: temp_size + INTEGER :: error ! error return value + TYPE(C_PTR) :: f_ptr + TYPE(C_PTR), DIMENSION(1:count) :: f_ptr1 + TYPE(C_PTR), DIMENSION(1:1) :: f_ptr2 + + INTEGER(HSIZE_T) :: sizeof_buffer + + ! Initialize file image buffer + DO i = 1, count + buffer(i) = i*10 + ENDDO + + ! Create fapl + CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl_1, error) + CALL check("h5pcreate_f", error, total_error) + + ! Test with NULL ptr + f_ptr2(1) = C_NULL_PTR + temp_size = 1 + CALL h5pget_file_image_f(fapl_1, f_ptr2, temp_size, error) + CALL check("h5pget_file_image_f", error, total_error) + CALL verify("h5pget_file_image_f", INT(temp_size), 0, total_error) + + ! Set file image + f_ptr = C_LOC(buffer(1)) + size = H5_SIZEOF(buffer(1))*count + + CALL h5pset_file_image_f(fapl_1, f_ptr, size, error) + CALL check("h5pset_file_image_f", error, total_error) + + ! Get the same data back + DO i = 1, count + f_ptr1(i) = C_LOC(temp(i)) + ENDDO + + temp_size = 0 + CALL h5pget_file_image_f(fapl_1, f_ptr1, temp_size, error) + CALL check("h5pget_file_image_f", error, total_error) + + ! Check that sizes are the same, and that the buffers are identical but separate + CALL verify("h5pget_file_image_f", INT(temp_size), INT(size), total_error) + + ! Verify the image data is correct + DO i = 1, count + CALL verify("h5pget_file_image_f", temp(i), buffer(i), total_error) + ENDDO + +END SUBROUTINE test_h5p_file_image + +!------------------------------------------------------------------------- +! Function: external_test_offset +! +! Purpose: Tests APIs: +! h5pset_external_f (with offsets not equal to zero), h5pget_external_f +! +! Return: Success: 0 +! Failure: -1 +! +! FORTRAN Programmer: M. Scot Breitenfeld +! January 10, 2012 +!------------------------------------------------------------------------- +! +SUBROUTINE external_test_offset(cleanup,total_error) + + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: total_error + LOGICAL, INTENT(IN) :: cleanup + + INTEGER(hid_t) :: fapl=-1 ! file access property list + INTEGER(hid_t) :: file=-1 ! file to write to + INTEGER(hid_t) :: dcpl=-1 ! dataset creation properties + INTEGER(hid_t) :: space=-1 ! data space + INTEGER(hid_t) :: dset=-1 ! dataset + INTEGER(hid_t) :: grp=-1 ! group to emit diagnostics + INTEGER(size_t) :: i, j ! miscellaneous counters + CHARACTER(LEN=180) :: filename ! file names + INTEGER, DIMENSION(1:25) :: part + INTEGER, DIMENSION(1:100), TARGET :: whole ! raw data buffers + INTEGER(hsize_t), DIMENSION(1:1) :: cur_size ! current data space size + INTEGER(hid_t) :: hs_space ! hyperslab data space + INTEGER(hsize_t), DIMENSION(1:1) :: hs_start = (/30/) ! hyperslab starting offset + INTEGER(hsize_t), DIMENSION(1:1) :: hs_count = (/25/) ! hyperslab size + CHARACTER(LEN=1) :: ichr1 ! character conversion holder + INTEGER :: error ! error status + TYPE(C_PTR) :: f_ptr ! fortran pointer + INTEGER(HSIZE_T) :: sizeof_part + + CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(1:30) :: temparray + + temparray(1:30)(1:1) = '0' ! 1 byte character + + ! Write the data to external files directly + DO i = 1, 4 + DO j = 1, 25 + part(j) = (i-1)*25+(j-1) + ENDDO + WRITE(ichr1,'(I1.1)') i + filename = "extern_"//ichr1//"a.raw" + OPEN(10, FILE=filename, ACCESS='STREAM', form='UNFORMATTED') + + WRITE(10) temparray(1:(i-1)*10) + WRITE(10) part + CLOSE(10) + ENDDO + ! + ! Create the file and an initial group. + CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) + CALL h5fcreate_f('extren_raw.h5', H5F_ACC_TRUNC_F, file, error, access_prp=fapl) + CALL check("h5fcreate_f",error,total_error) + + CALL h5gcreate_f(file, "emit-diagnostics", grp, error) + CALL check("h5gcreate_f",error, total_error) + + ! Create the dataset + + sizeof_part = INT(H5_SIZEOF(part(1))*25, hsize_t) + + CALL h5pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_external_f(dcpl, "extern_1a.raw", INT(0,off_t), sizeof_part, error) + CALL check("h5pset_external_f",error,total_error) + CALL h5pset_external_f(dcpl, "extern_2a.raw", INT(10,off_t), sizeof_part, error) + CALL check("h5pset_external_f",error,total_error) + CALL h5pset_external_f(dcpl, "extern_3a.raw", INT(20,off_t), sizeof_part, error) + CALL check("h5pset_external_f",error,total_error) + CALL h5pset_external_f(dcpl, "extern_4a.raw", INT(30,off_t), sizeof_part, error) + CALL check("h5pset_external_f",error,total_error) + + cur_size(1) = 100 + CALL h5screate_simple_f(1, cur_size, space, error) + CALL check("h5screate_simple_f", error, total_error) + CALL h5dcreate_f(file, "dset1", H5T_NATIVE_INTEGER, space, dset,error,dcpl_id=dcpl) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Read the entire dataset and compare with the original + whole(:) = 0 + f_ptr = C_LOC(whole(1)) + CALL h5dread_f(dset, H5T_NATIVE_INTEGER, f_ptr, error, mem_space_id=space, file_space_id=space) + CALL check("h5dread_f", error, total_error) + + DO i = 1, 100 + IF(whole(i) .NE. i-1)THEN + WRITE(*,*) "Incorrect value(s) read." + total_error = total_error + 1 + EXIT + ENDIF + ENDDO + ! + ! Read the middle of the dataset + CALL h5scopy_f(space, hs_space, error) + CALL check("h5scopy_f", error, total_error) + CALL h5sselect_hyperslab_f(hs_space, H5S_SELECT_SET_F, hs_start, hs_count, error) + CALL check("h5sselect_hyperslab_f", error, total_error) + + whole(:) = 0 + f_ptr = C_LOC(whole(1)) + CALL h5dread_f(dset, H5T_NATIVE_INTEGER, f_ptr, error, mem_space_id=hs_space, file_space_id=hs_space) + CALL check("h5dread_f", error, total_error) + + CALL h5sclose_f(hs_space, error) + CALL check("h5sclose_f", error, total_error) + DO i = INT(hs_start(1))+1, INT(hs_start(1)+hs_count(1)) + IF(whole(i) .NE. i-1)THEN + WRITE(*,*) "Incorrect value(s) read." + total_error = total_error + 1 + EXIT + ENDIF + ENDDO + + CALL h5dclose_f(dset, error) + CALL check("h5dclose_f", error, total_error) + CALL h5pclose_f(dcpl, error) + CALL check("h5pclose_f", error, total_error) + CALL h5sclose_f(space, error) + CALL check("h5sclose_f", error, total_error) + CALL h5fclose_f(file, error) + CALL check("h5fclose_f", error, total_error) + + ! cleanup + DO i = 1, 4 + WRITE(ichr1,'(I1.1)') i + filename = "extern_"//ichr1//"a.raw" + CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + ENDDO + IF(cleanup) CALL h5_cleanup_f("extren_raw.h5", H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + +END SUBROUTINE external_test_offset +END MODULE TH5P_F03 diff --git a/fortran/test/tH5P_F03.f90 b/fortran/test/tH5P_F03.f90 deleted file mode 100644 index ec9fef2..0000000 --- a/fortran/test/tH5P_F03.f90 +++ /dev/null @@ -1,617 +0,0 @@ -!****h* root/fortran/test/tH5P_F03.f90 -! -! NAME -! tH5P_F03.f90 -! -! FUNCTION -! Test FORTRAN HDF5 H5P 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! USES -! test_genprop_cls_cb1_mod -! -! CONTAINS SUBROUTINES -! test_create, test_genprop_class_callback -! -!***** - -! ***************************************** -! *** H 5 P T E S T S -! ***************************************** -MODULE test_genprop_cls_cb1_mod - - ! Callback subroutine for test_genprop_class_callback - ! and the function H5Pcreate_class_f. - - USE HDF5 - USE ISO_C_BINDING - IMPLICIT NONE - - TYPE, BIND(C) :: cop_cb_struct_ ! Struct for iterations - INTEGER :: count - INTEGER(HID_T) :: id - END TYPE cop_cb_struct_ - -CONTAINS - - INTEGER FUNCTION test_genprop_cls_cb1_f(list_id, create_data ) bind(C) - - IMPLICIT NONE - - INTEGER(HID_T), INTENT(IN), VALUE :: list_id - - TYPE(cop_cb_struct_) :: create_data - - create_data%count = create_data%count + 1 - create_data%id = list_id - - test_genprop_cls_cb1_f = 0 - - END FUNCTION test_genprop_cls_cb1_f - -END MODULE test_genprop_cls_cb1_mod - -MODULE TH5P_F03 - - USE HDF5 - USE TH5_MISC - USE TH5_MISC_GEN - USE ISO_C_BINDING - -CONTAINS - -!------------------------------------------------------------------------- -! * Function: test_create -! * -! * Purpose: Tests H5Pset_fill_value_f and H5Pget_fill_value_f -! * -! * Return: Success: 0 -! * -! * Failure: number of errors -! * -! * Programmer: M. Scot Breitenfeld -! * June 24, 2008 -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - -SUBROUTINE test_create(total_error) - - IMPLICIT NONE - - INTEGER, INTENT(INOUT) :: total_error - INTEGER(HID_T) :: fapl - - INTEGER(hid_t) :: file=-1, space=-1, dcpl=-1, comp_type_id=-1 - INTEGER(hid_t) :: dset9=-1 - INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: cur_size = (/2, 8, 8, 4, 2/) - INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: ch_size= (/1, 1, 1, 4, 1/) - CHARACTER(LEN=14) :: filename ='test_create.h5' - - TYPE(comp_datatype), TARGET :: rd_c, fill_ctype - INTEGER :: error - INTEGER(SIZE_T) :: h5off - TYPE(C_PTR) :: f_ptr - LOGICAL :: differ1, differ2 - CHARACTER(LEN=1) :: cfill - INTEGER :: ifill - REAL :: rfill - REAL(KIND=dp) :: dpfill - - ! - ! * Create a file. - ! - CALL h5fcreate_f(filename,H5F_ACC_TRUNC_F,file,error) - CALL check("h5fcreate_f", error, total_error) - - CALL h5screate_simple_f(5, cur_size, space, error, cur_size) - CALL check("h5screate_simple_f", error, total_error) - - CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) - CALL check("H5Pcreate_f", error, total_error) - - CALL h5pset_chunk_f(dcpl, 5, ch_size, error) - CALL check("h5pset_chunk_f",error, total_error) - - ! Create a compound datatype - CALL h5tcreate_f(H5T_COMPOUND_F, H5_SIZEOF(fill_ctype), comp_type_id, error) - CALL check("h5tcreate_f", error, total_error) - h5off = H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%a)) - CALL h5tinsert_f(comp_type_id, "a", h5off , H5T_NATIVE_REAL, error) - CALL check("h5tinsert_f", error, total_error) - CALL h5tinsert_f(comp_type_id, "x", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%x)), H5T_NATIVE_INTEGER, error) - CALL check("h5tinsert_f", error, total_error) - CALL h5tinsert_f(comp_type_id, "y", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%y)), H5T_NATIVE_DOUBLE, error) - CALL check("h5tinsert_f", error, total_error) - CALL h5tinsert_f(comp_type_id, "z", & - H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%z)), H5T_NATIVE_CHARACTER, error) - CALL check("h5tinsert_f", error, total_error) - - - CALL H5Pset_alloc_time_f(dcpl, H5D_ALLOC_TIME_LATE_F,error) - CALL check("H5Pset_alloc_time_f",error, total_error) - - CALL H5Pset_fill_time_f(dcpl, H5D_FILL_TIME_ALLOC_F, error) - CALL check("H5Pset_fill_time_f",error, total_error) - - ! Compound datatype test - - f_ptr = C_LOC(fill_ctype) - - CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error) - CALL check("H5Pget_fill_value_f",error, total_error) - - fill_ctype%y = 4444.D0 - fill_ctype%z = 'S' - fill_ctype%a = 5555. - fill_ctype%x = 55 - - f_ptr = C_LOC(fill_ctype) - - ! Test various fill values - CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_CHARACTER, 'X', error) - CALL check("H5Pset_fill_value_f",error, total_error) - CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_CHARACTER, cfill, error) - CALL check("H5Pget_fill_value_f",error, total_error) - IF(cfill.NE.'X')THEN - PRINT*,"***ERROR: Returned wrong fill value (character)" - total_error = total_error + 1 - ENDIF - CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_INTEGER, 9, error) - CALL check("H5Pset_fill_value_f",error, total_error) - CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_INTEGER, ifill, error) - CALL check("H5Pget_fill_value_f",error, total_error) - IF(ifill.NE.9)THEN - PRINT*,"***ERROR: Returned wrong fill value (integer)" - total_error = total_error + 1 - ENDIF - CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_DOUBLE, 1.0_dp, error) - CALL check("H5Pset_fill_value_f",error, total_error) - CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_DOUBLE, dpfill, error) - CALL check("H5Pget_fill_value_f",error, total_error) - CALL VERIFY("***ERROR: Returned wrong fill value (double)", dpfill, 1.0_dp, total_error) - CALL H5Pset_fill_value_f(dcpl, H5T_NATIVE_REAL, 2.0, error) - CALL check("H5Pset_fill_value_f",error, total_error) - CALL h5pget_fill_value_f(dcpl, H5T_NATIVE_REAL, rfill, error) - CALL check("H5Pget_fill_value_f",error, total_error) - CALL VERIFY("***ERROR: Returned wrong fill value (real)", rfill, 2.0, total_error) - - ! For the actual compound type - CALL H5Pset_fill_value_f(dcpl, comp_type_id, f_ptr, error) - CALL check("H5Pget_fill_value_f",error, total_error) - - CALL h5dcreate_f(file,"dset9", comp_type_id, space, dset9, error, dcpl_id=dcpl) - CALL check("h5dcreate_f", error, total_error) - - CALL h5dclose_f(dset9, error) - CALL check("h5dclose_f", error, total_error) - - CALL h5fclose_f(file,error) - CALL check("h5fclose_f", error, total_error) - - ! Open the file and get the dataset fill value from each dataset - CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error) - CALL check("H5Pcreate_f",error, total_error) - - CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) - CALL check("H5Pset_libver_bounds_f",error, total_error) - - CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, file, error, fapl) - CALL check("h5fopen_f", error, total_error) - - ! Compound datatype test - CALL h5dopen_f(file, "dset9", dset9, error) - CALL check("h5dopen_f", error, total_error) - - CALL H5Dget_create_plist_f(dset9, dcpl, error) - CALL check("H5Dget_create_plist_f", error, total_error) - - f_ptr = C_LOC(rd_c) - - CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error) - CALL check("H5Pget_fill_value_f", error, total_error) - CALL verify("***ERROR: Returned wrong fill value", rd_c%a, fill_ctype%a, total_error) - CALL verify("***ERROR: Returned wrong fill value", rd_c%y, fill_ctype%y, total_error) - - IF( rd_c%x .NE. fill_ctype%x .OR. & - rd_c%z .NE. fill_ctype%z )THEN - - PRINT*,"***ERROR: Returned wrong fill value" - total_error = total_error + 1 - - ENDIF - - CALL h5dclose_f(dset9, error) - CALL check("h5dclose_f", error, total_error) - - CALL H5Pclose_f(dcpl, error) - CALL check("H5Pclose_f", error, total_error) - - CALL h5fclose_f(file,error) - CALL check("h5fclose_f", error, total_error) - -END SUBROUTINE test_create - - -SUBROUTINE test_genprop_class_callback(total_error) - - ! - ! - ! test_genprop_class_callback(): Test basic generic property list code. - ! Tests callbacks for property lists in a generic class. - ! - ! FORTRAN TESTS: - ! Tests function H5Pcreate_class_f with callback. - ! - ! - - USE test_genprop_cls_cb1_mod - IMPLICIT NONE - - INTEGER, INTENT(INOUT) :: total_error - - INTEGER(hid_t) :: cid1, cid2 ! Generic Property class ID - INTEGER(hid_t) :: lid1, lid2 ! Generic Property list ID - INTEGER(size_t) :: nprops ! Number of properties in class - - TYPE(cop_cb_struct_), TARGET :: crt_cb_struct, cls_cb_struct - INTEGER :: CLASS1_NAME_SIZE = 7 ! length of class string - CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1", CLASS1_NAME_BUF - TYPE(C_FUNPTR) :: f1, f5 - TYPE(C_PTR) :: f2, f6 - - CHARACTER(LEN=10) :: PROP1_NAME = "Property 1" - INTEGER(SIZE_T) :: PROP1_SIZE = 10 - CHARACTER(LEN=10) :: PROP2_NAME = "Property 2" - INTEGER(SIZE_T) :: PROP2_SIZE = 10 - CHARACTER(LEN=10) :: PROP3_NAME = "Property 3" - INTEGER(SIZE_T) :: PROP3_SIZE = 10 - CHARACTER(LEN=10) :: PROP4_NAME = "Property 4" - INTEGER(SIZE_T) :: PROP4_SIZE = 10 - INTEGER :: PROP1_DEF_VALUE = 10 - INTEGER :: PROP2_DEF_VALUE = 10 - INTEGER :: PROP3_DEF_VALUE = 10 - INTEGER :: PROP4_DEF_VALUE = 10 - - INTEGER :: error ! Generic RETURN value - LOGICAL :: flag ! for tests - - f1 = C_FUNLOC(test_genprop_cls_cb1_f) - f5 = C_FUNLOC(test_genprop_cls_cb1_f) - - f2 = C_LOC(crt_cb_struct) - f6 = C_LOC(cls_cb_struct) - - ! Create a new generic class, derived from the root of the class hierarchy - CALL h5pcreate_class_f(h5p_ROOT_F, CLASS1_NAME, cid1, error, f1, f2, c_null_funptr, c_null_ptr, f5, f6) - CALL check("h5pcreate_class_f", error, total_error) - - ! Insert first property into class (with no callbacks) - CALL h5pregister_f(cid1, PROP1_NAME, PROP1_SIZE, PROP1_DEF_VALUE, error) - CALL check("h5pregister_f", error, total_error) - ! Insert second property into class (with no callbacks) - CALL h5pregister_f(cid1, PROP2_NAME, PROP2_SIZE, PROP2_DEF_VALUE, error) - CALL check("h5pregister_f", error, total_error) - ! Insert third property into class (with no callbacks) - CALL h5pregister_f(cid1, PROP3_NAME, PROP3_SIZE, PROP3_DEF_VALUE, error) - CALL check("h5pregister_f", error, total_error) - - ! Insert fourth property into class (with no callbacks) - CALL h5pregister_f(cid1, PROP4_NAME, PROP4_SIZE, PROP4_DEF_VALUE, error) - CALL check("h5pregister_f", error, total_error) - - ! Check the number of properties in class - CALL h5pget_nprops_f(cid1, nprops, error) - CALL check("h5pget_nprops_f", error, total_error) - CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) - - ! Initialize class callback structs - - crt_cb_struct%count = 0 - crt_cb_struct%id = -1 - cls_cb_struct%count = 0 - cls_cb_struct%id = -1 - - ! Create a property list from the class - CALL h5pcreate_f(cid1, lid1, error) - CALL check("h5pcreate_f", error, total_error) - - ! Get the list's class - CALL H5Pget_class_f(lid1, cid2, error) - CALL check("H5Pget_class_f", error, total_error) - - ! Check that the list's class is correct - CALL H5Pequal_f(cid2, cid1, flag, error) - CALL check("H5Pequal_f", error, total_error) - CALL verify("H5Pequal_f", flag, .TRUE., total_error) - - ! Check the class name - CALL H5Pget_class_name_f(cid2, CLASS1_NAME_BUF, CLASS1_NAME_SIZE, error) - CALL check("H5Pget_class_name_f", error, total_error) - CALL verify("H5Pget_class_name_f", CLASS1_NAME_BUF, CLASS1_NAME, error) - IF(error.NE.0)THEN - WRITE(*,*) 'Class names do not match! name=',CLASS1_NAME_BUF, 'CLASS1_NAME=',CLASS1_NAME - total_error = total_error + 1 - ENDIF - ! Close class - CALL h5pclose_class_f(cid2, error) - CALL check("h5pclose_class_f", error, total_error) - - ! Verify that the creation callback occurred - CALL verify("h5pcreate_f", crt_cb_struct%count, 1, total_error) - CALL verify("h5pcreate_f", crt_cb_struct%id, lid1, total_error) - - ! Check the number of properties in list - CALL h5pget_nprops_f(lid1,nprops, error) - CALL check("h5pget_nprops_f", error, total_error) - CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) - - ! Create another property list from the class - CALL h5pcreate_f(cid1, lid2, error) - CALL check("h5pcreate_f", error, total_error) - - ! Verify that the creation callback occurred - CALL verify("h5pcreate_f", crt_cb_struct%count, 2, total_error) - CALL verify("h5pcreate_f", crt_cb_struct%id, lid2, total_error) - - ! Check the number of properties in list - CALL h5pget_nprops_f(lid2,nprops, error) - CALL check("h5pget_nprops_f", error, total_error) - CALL verify("h5pget_nprops_f", INT(nprops), 4, total_error) - - ! Close first list - CALL h5pclose_f(lid1, error); - CALL check("h5pclose_f", error, total_error) - - ! Verify that the close callback occurred - CALL verify("h5pcreate_f", cls_cb_struct%count, 1, total_error) - CALL verify("h5pcreate_f", cls_cb_struct%id, lid1, total_error) - - ! Close second list - CALL h5pclose_f(lid2, error); - CALL check("h5pclose_f", error, total_error) - - ! Verify that the close callback occurred - CALL verify("h5pcreate_f", cls_cb_struct%count, 2, total_error) - CALL verify("h5pcreate_f", cls_cb_struct%id, lid2, total_error) - - ! Close class - CALL h5pclose_class_f(cid1, error) - CALL check("h5pclose_class_f", error, total_error) - -END SUBROUTINE test_genprop_class_callback - -!------------------------------------------------------------------------- -! Function: test_h5p_file_image -! -! Purpose: Tests APIs: -! h5pget_file_image_f and h5pset_file_image_f -! -! Return: Success: 0 -! Failure: -1 -! -! FORTRAN Programmer: M. Scot Breitenfeld -! April 1, 2014 -!------------------------------------------------------------------------- - -SUBROUTINE test_h5p_file_image(total_error) - - USE, INTRINSIC :: iso_c_binding - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - INTEGER(hid_t) :: fapl_1 = -1 - INTEGER, PARAMETER :: count = 10 - INTEGER, DIMENSION(1:count), TARGET :: buffer - INTEGER, DIMENSION(1:count), TARGET :: temp - INTEGER :: i - INTEGER(size_t) :: size - INTEGER(size_t) :: temp_size - INTEGER :: error ! error return value - TYPE(C_PTR) :: f_ptr - TYPE(C_PTR), DIMENSION(1:count) :: f_ptr1 - TYPE(C_PTR), DIMENSION(1:1) :: f_ptr2 - - INTEGER(HSIZE_T) :: sizeof_buffer - - ! Initialize file image buffer - DO i = 1, count - buffer(i) = i*10 - ENDDO - - ! Create fapl - CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl_1, error) - CALL check("h5pcreate_f", error, total_error) - - ! Test with NULL ptr - f_ptr2(1) = C_NULL_PTR - temp_size = 1 - CALL h5pget_file_image_f(fapl_1, f_ptr2, temp_size, error) - CALL check("h5pget_file_image_f", error, total_error) - CALL verify("h5pget_file_image_f", INT(temp_size), 0, total_error) - - ! Set file image - f_ptr = C_LOC(buffer(1)) - size = H5_SIZEOF(buffer(1))*count - - CALL h5pset_file_image_f(fapl_1, f_ptr, size, error) - CALL check("h5pset_file_image_f", error, total_error) - - ! Get the same data back - DO i = 1, count - f_ptr1(i) = C_LOC(temp(i)) - ENDDO - - temp_size = 0 - CALL h5pget_file_image_f(fapl_1, f_ptr1, temp_size, error) - CALL check("h5pget_file_image_f", error, total_error) - - ! Check that sizes are the same, and that the buffers are identical but separate - CALL verify("h5pget_file_image_f", INT(temp_size), INT(size), total_error) - - ! Verify the image data is correct - DO i = 1, count - CALL verify("h5pget_file_image_f", temp(i), buffer(i), total_error) - ENDDO - -END SUBROUTINE test_h5p_file_image - -!------------------------------------------------------------------------- -! Function: external_test_offset -! -! Purpose: Tests APIs: -! h5pset_external_f (with offsets not equal to zero), h5pget_external_f -! -! Return: Success: 0 -! Failure: -1 -! -! FORTRAN Programmer: M. Scot Breitenfeld -! January 10, 2012 -!------------------------------------------------------------------------- -! -SUBROUTINE external_test_offset(cleanup,total_error) - - IMPLICIT NONE - INTEGER, INTENT(INOUT) :: total_error - LOGICAL, INTENT(IN) :: cleanup - - INTEGER(hid_t) :: fapl=-1 ! file access property list - INTEGER(hid_t) :: file=-1 ! file to write to - INTEGER(hid_t) :: dcpl=-1 ! dataset creation properties - INTEGER(hid_t) :: space=-1 ! data space - INTEGER(hid_t) :: dset=-1 ! dataset - INTEGER(hid_t) :: grp=-1 ! group to emit diagnostics - INTEGER(size_t) :: i, j ! miscellaneous counters - CHARACTER(LEN=180) :: filename ! file names - INTEGER, DIMENSION(1:25) :: part - INTEGER, DIMENSION(1:100), TARGET :: whole ! raw data buffers - INTEGER(hsize_t), DIMENSION(1:1) :: cur_size ! current data space size - INTEGER(hid_t) :: hs_space ! hyperslab data space - INTEGER(hsize_t), DIMENSION(1:1) :: hs_start = (/30/) ! hyperslab starting offset - INTEGER(hsize_t), DIMENSION(1:1) :: hs_count = (/25/) ! hyperslab size - CHARACTER(LEN=1) :: ichr1 ! character conversion holder - INTEGER :: error ! error status - TYPE(C_PTR) :: f_ptr ! fortran pointer - INTEGER(HSIZE_T) :: sizeof_part - - CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(1:30) :: temparray - - temparray(1:30)(1:1) = '0' ! 1 byte character - - ! Write the data to external files directly - DO i = 1, 4 - DO j = 1, 25 - part(j) = (i-1)*25+(j-1) - ENDDO - WRITE(ichr1,'(I1.1)') i - filename = "extern_"//ichr1//"a.raw" - OPEN(10, FILE=filename, ACCESS='STREAM', form='UNFORMATTED') - - WRITE(10) temparray(1:(i-1)*10) - WRITE(10) part - CLOSE(10) - ENDDO - ! - ! Create the file and an initial group. - CALL h5pcreate_f(H5P_FILE_ACCESS_F, fapl, error) - CALL h5fcreate_f('extren_raw.h5', H5F_ACC_TRUNC_F, file, error, access_prp=fapl) - CALL check("h5fcreate_f",error,total_error) - - CALL h5gcreate_f(file, "emit-diagnostics", grp, error) - CALL check("h5gcreate_f",error, total_error) - - ! Create the dataset - - sizeof_part = INT(H5_SIZEOF(part(1))*25, hsize_t) - - CALL h5pcreate_f(H5P_DATASET_CREATE_F, dcpl, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_external_f(dcpl, "extern_1a.raw", INT(0,off_t), sizeof_part, error) - CALL check("h5pset_external_f",error,total_error) - CALL h5pset_external_f(dcpl, "extern_2a.raw", INT(10,off_t), sizeof_part, error) - CALL check("h5pset_external_f",error,total_error) - CALL h5pset_external_f(dcpl, "extern_3a.raw", INT(20,off_t), sizeof_part, error) - CALL check("h5pset_external_f",error,total_error) - CALL h5pset_external_f(dcpl, "extern_4a.raw", INT(30,off_t), sizeof_part, error) - CALL check("h5pset_external_f",error,total_error) - - cur_size(1) = 100 - CALL h5screate_simple_f(1, cur_size, space, error) - CALL check("h5screate_simple_f", error, total_error) - CALL h5dcreate_f(file, "dset1", H5T_NATIVE_INTEGER, space, dset,error,dcpl_id=dcpl) - CALL check("h5dcreate_f", error, total_error) - - ! - ! Read the entire dataset and compare with the original - whole(:) = 0 - f_ptr = C_LOC(whole(1)) - CALL h5dread_f(dset, H5T_NATIVE_INTEGER, f_ptr, error, mem_space_id=space, file_space_id=space) - CALL check("h5dread_f", error, total_error) - - DO i = 1, 100 - IF(whole(i) .NE. i-1)THEN - WRITE(*,*) "Incorrect value(s) read." - total_error = total_error + 1 - EXIT - ENDIF - ENDDO - ! - ! Read the middle of the dataset - CALL h5scopy_f(space, hs_space, error) - CALL check("h5scopy_f", error, total_error) - CALL h5sselect_hyperslab_f(hs_space, H5S_SELECT_SET_F, hs_start, hs_count, error) - CALL check("h5sselect_hyperslab_f", error, total_error) - - whole(:) = 0 - f_ptr = C_LOC(whole(1)) - CALL h5dread_f(dset, H5T_NATIVE_INTEGER, f_ptr, error, mem_space_id=hs_space, file_space_id=hs_space) - CALL check("h5dread_f", error, total_error) - - CALL h5sclose_f(hs_space, error) - CALL check("h5sclose_f", error, total_error) - DO i = INT(hs_start(1))+1, INT(hs_start(1)+hs_count(1)) - IF(whole(i) .NE. i-1)THEN - WRITE(*,*) "Incorrect value(s) read." - total_error = total_error + 1 - EXIT - ENDIF - ENDDO - - CALL h5dclose_f(dset, error) - CALL check("h5dclose_f", error, total_error) - CALL h5pclose_f(dcpl, error) - CALL check("h5pclose_f", error, total_error) - CALL h5sclose_f(space, error) - CALL check("h5sclose_f", error, total_error) - CALL h5fclose_f(file, error) - CALL check("h5fclose_f", error, total_error) - - ! cleanup - DO i = 1, 4 - WRITE(ichr1,'(I1.1)') i - filename = "extern_"//ichr1//"a.raw" - CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - ENDDO - IF(cleanup) CALL h5_cleanup_f("extren_raw.h5", H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - -END SUBROUTINE external_test_offset -END MODULE TH5P_F03 diff --git a/fortran/test/tH5R.F90 b/fortran/test/tH5R.F90 new file mode 100644 index 0000000..ef392b4 --- /dev/null +++ b/fortran/test/tH5R.F90 @@ -0,0 +1,483 @@ +!****h* root/fortran/test/tH5R.f90 +! +! NAME +! tH5R.f90 +! +! FUNCTION +! Basic testing of Fortran H5R, Reference Interface, APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests h5rcreate_f, h5rdereference_f, h5rget_name_f +! and H5Rget_object_type functions +! +! CONTAINS SUBROUTINES +! refobjtest, refregtest +! +!***** +! +MODULE TH5R + + USE HDF5 + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + +SUBROUTINE refobjtest(cleanup, total_error) + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=9), PARAMETER :: filename = "reference" + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=8), PARAMETER :: dsetnamei = "INTEGERS" + CHARACTER(LEN=17), PARAMETER :: dsetnamer = "OBJECT_REFERENCES" + CHARACTER(LEN=6), PARAMETER :: groupname1 = "GROUP1" + CHARACTER(LEN=6), PARAMETER :: groupname2 = "GROUP2" + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: grp1_id ! Group identifier + INTEGER(HID_T) :: grp2_id ! Group identifier + INTEGER(HID_T) :: dset1_id ! Dataset identifier + INTEGER(HID_T) :: dsetr_id ! Dataset identifier + INTEGER(HID_T) :: type_id ! Type identifier + INTEGER(HID_T) :: space_id ! Dataspace identifier + INTEGER(HID_T) :: spacer_id ! Dataspace identifier + INTEGER :: error, obj_type + INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/5/) + INTEGER(HSIZE_T), DIMENSION(1) :: dimsr= (/4/) + INTEGER(HSIZE_T), DIMENSION(1) :: my_maxdims = (/5/) + INTEGER :: rank = 1 + INTEGER :: rankr = 1 + TYPE(hobj_ref_t_f), DIMENSION(4) :: ref + TYPE(hobj_ref_t_f), DIMENSION(4) :: ref_out + INTEGER(HSIZE_T), DIMENSION(1) :: ref_dim + INTEGER, DIMENSION(5) :: DATA = (/1, 2, 3, 4, 5/) + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + + CHARACTER(LEN=7) :: buf ! buffer to hold the region name + CHARACTER(LEN=16) :: buf_big ! buffer bigger then needed + INTEGER(SIZE_T) :: buf_size ! returned size of the region buffer name + + ! + !Create a new file with Default file access and + !file creation properties . + ! + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + WRITE(*,*) "Cannot modify filename" + STOP + ENDIF + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f",error,total_error) + + + ! + ! Create a group inside the file + ! + CALL h5gcreate_f(file_id, groupname1, grp1_id, error) + CALL check("h5gcreate_f",error,total_error) + + ! + ! Create a group inside the group GROUP1 + ! + CALL h5gcreate_f(grp1_id, groupname2, grp2_id, error) + CALL check("h5gcreate_f",error,total_error) + + ! + ! Create dataspaces for datasets + ! + CALL h5screate_simple_f(rank, dims, space_id, error, maxdims=my_maxdims) + CALL check("h5screate_simple_f",error,total_error) + CALL h5screate_simple_f(rankr, dimsr, spacer_id, error) + CALL check("h5screate_simple_f",error,total_error) + + ! + ! Create integer dataset + ! + CALL h5dcreate_f(file_id, dsetnamei, H5T_NATIVE_INTEGER, space_id, & + dset1_id, error) + CALL check("h5dcreate_f",error,total_error) + ! + ! Create dataset to store references to the objects + ! + CALL h5dcreate_f(file_id, dsetnamer, H5T_STD_REF_OBJ, spacer_id, & + dsetr_id, error) + CALL check("h5dcreate_f",error,total_error) + ! + ! Create a datatype and store in the file + ! + CALL h5tcopy_f(H5T_NATIVE_REAL, type_id, error) + CALL check("h5tcopy_f",error,total_error) + CALL h5tcommit_f(file_id, "MyType", type_id, error) + CALL check("h5tcommit_f",error,total_error) + ! + ! Close dataspaces, groups and integer dataset + ! + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5sclose_f(spacer_id, error) + CALL check("h5sclose_f",error,total_error) + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f",error,total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f",error,total_error) + CALL h5gclose_f(grp1_id, error) + CALL check("h5gclose_f",error,total_error) + CALL h5gclose_f(grp2_id, error) + CALL check("h5gclose_f",error,total_error) + + ! + ! Craete references to two groups, integer dataset and shared datatype + ! and write it to the dataset in the file + ! + CALL h5rcreate_f(file_id, groupname1, ref(1), error) + CALL check("h5rcreate_f",error,total_error) + CALL h5rcreate_f(file_id, "/GROUP1/GROUP2", ref(2), error) + CALL check("h5rcreate_f",error,total_error) + CALL h5rcreate_f(file_id, dsetnamei, ref(3), error) + CALL check("h5rcreate_f",error,total_error) + CALL h5rcreate_f(file_id, "MyType", ref(4), error) + CALL check("h5rcreate_f",error,total_error) + ref_dim(1) = SIZE(ref) + CALL h5dwrite_f(dsetr_id, H5T_STD_REF_OBJ, ref, ref_dim, error) + CALL check("h5dwrite_f",error,total_error) + + ! getting path to normal dataset in root group + + CALL H5Rget_name_f(dsetr_id, ref(1), buf, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + + + CALL verify("H5Rget_name_f", INT(buf_size),7, total_error) + CALL verify("H5Rget_name_f", buf, "/GROUP1", total_error) + + ! with buffer bigger then needed + + CALL H5Rget_name_f(dsetr_id, ref(1), buf_big, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) + CALL verify("H5Rget_name_f", TRIM(buf_big), "/GROUP1", total_error) + + ! getting path to dataset in /Group1 + + CALL H5Rget_name_f(dsetr_id, ref(2), buf_big, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", INT(buf_size),14,total_error) + CALL verify("H5Rget_name_f", TRIM(buf_big), "/GROUP1/GROUP2", total_error) + + ! + !Close the dataset + ! + CALL h5dclose_f(dsetr_id, error) + CALL check("h5dclose_f",error,total_error) + + ! + ! Reopen the dataset with object references + ! + CALL h5dopen_f(file_id, dsetnamer,dsetr_id,error) + CALL check("h5dopen_f",error,total_error) + ref_dim(1) = SIZE(ref_out) + CALL h5dread_f(dsetr_id, H5T_STD_REF_OBJ, ref_out, ref_dim, error) + CALL check("h5dread_f",error,total_error) + + ! + !get the third reference's type and Dereference it + ! + CALL h5rget_object_type_f(dsetr_id, ref(3), obj_type, error) + CALL check("h5rget_object_type_f",error,total_error) + IF (obj_type == H5G_DATASET_F) THEN + CALL h5rdereference_f(dsetr_id, ref(3), dset1_id, error) + CALL check("h5rdereference_f",error,total_error) + + data_dims(1) = 5 + CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, DATA, data_dims, error) + CALL check("h5dwrite_f",error,total_error) + END IF + + ! + !get the fourth reference's type and Dereference it + ! + CALL h5rget_object_type_f(dsetr_id, ref(4), obj_type, error) + CALL check("h5rget_object_type_f",error,total_error) + IF (obj_type == H5G_TYPE_F) THEN + CALL h5rdereference_f(dsetr_id, ref(4), type_id, error) + CALL check("h5rdereference_f",error,total_error) + END IF + + ! + ! Close all objects. + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f",error,total_error) + CALL h5tclose_f(type_id, error) + CALL check("h5tclose_f",error,total_error) + + CALL h5dclose_f(dsetr_id, error) + CALL check("h5dclose_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 refobjtest +! +! The following subroutine tests h5rget_region_f, h5rcreate_f, h5rget_name_f, +! and h5rdereference_f functionalities +! +SUBROUTINE refregtest(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=6), PARAMETER :: filename = "Refreg" + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=6), PARAMETER :: dsetnamev = "MATRIX" + CHARACTER(LEN=17), PARAMETER :: dsetnamer = "REGION_REFERENCES" + + CHARACTER(LEN=7) :: buf ! buffer to hold the region name + CHARACTER(LEN=11) :: buf_big ! buffer bigger then needed + CHARACTER(LEN=4) :: buf_small ! buffer smaller then needed + INTEGER(SIZE_T) :: buf_size ! returned size of the region buffer name + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: space_id ! Dataspace identifier + INTEGER(HID_T) :: spacer_id ! Dataspace identifier + INTEGER(HID_T) :: dsetv_id ! Dataset identifier + INTEGER(HID_T) :: dsetr_id ! Dataset identifier + INTEGER :: error +! TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2), TARGET :: ref + TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref + TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref_out + INTEGER(HSIZE_T), DIMENSION(2) :: ref_dim = (/0,0/) + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims ! = (/0,0/) + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/2,9/) ! Datasets dimensions + INTEGER(HSIZE_T), DIMENSION(1) :: dimsr = (/2/) ! + INTEGER(HSIZE_T), DIMENSION(2) :: start ! = (/0,0/) + INTEGER(HSIZE_T), DIMENSION(2) :: count ! = (/0,0/) + + INTEGER :: rankr = 1 + INTEGER :: rank = 2 +! INTEGER , DIMENSION(2,9), TARGET :: DATA + INTEGER , DIMENSION(2,9) :: DATA + INTEGER , DIMENSION(2,9) :: data_out = 0 + INTEGER(HSIZE_T) , DIMENSION(2,3) :: coord + INTEGER(SIZE_T) ::num_points = 3 ! Number of selected points +! type(c_ptr) :: f_ptr + coord = RESHAPE((/1,1,2,7,1,9/), (/2,3/)) ! Coordinates of selected points + DATA = RESHAPE ((/1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6/), (/2,9/)) + + ref_out(1)%ref = 0 + ref_out(2)%ref = 0 + + ! + ! Initialize FORTRAN predefined datatypes. + ! + ! CALL h5init_types_f(error) + ! CALL check("h5init_types_f", error, total_error) + ! + ! Create a new file. + ! + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + WRITE(*,*) "Cannot modify filename" + STOP + ENDIF + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + ! Default file access and file creation + ! properties are used. + CALL check("h5fcreate_f", error, total_error) + ! + ! Create dataspaces: + ! + ! for dataset with references to dataset regions + ! + CALL h5screate_simple_f(rankr, dimsr, spacer_id, error) + CALL check("h5screate_simple_f", error, total_error) + ! + ! for integer dataset + ! + CALL h5screate_simple_f(rank, dims, space_id, error) + CALL check("h5screate_simple_f", error, total_error) + ! + ! Create and write datasets: + ! + ! Integer dataset + ! + CALL h5dcreate_f(file_id, dsetnamev, H5T_NATIVE_INTEGER, space_id, & + dsetv_id, error) + CALL check("h5dcreate_f", error, total_error) + data_dims(1) = 2 + data_dims(2) = 9 + +! f_ptr = c_loc(data) +! CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, f_ptr, error) + + CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, DATA, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + CALL h5dclose_f(dsetv_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + ! Dataset with references + ! + CALL h5dcreate_f(file_id, dsetnamer, H5T_STD_REF_DSETREG, spacer_id, & + dsetr_id, error) + CALL check("h5dcreate_f", error, total_error) + ! + ! Create a reference to the hyperslab selection. + ! + start(1) = 0 + start(2) = 3 + COUNT(1) = 2 + COUNT(2) = 3 + CALL h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, & + start, count, error) + CALL check("h5sselect_hyperslab_f", error, total_error) + ref(1)%ref(:) = 0 +! f_ptr = C_LOC(ref(1)) +! CALL h5rcreate_f(file_id, dsetnamev, 1, space_id, f_ptr, error) + CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(1), error) + CALL check("h5rcreate_f", error, total_error) + + ! + ! Create a reference to elements selection. + ! + CALL h5sselect_none_f(space_id, error) + CALL check("h5sselect_none_f", error, total_error) + CALL h5sselect_elements_f(space_id, H5S_SELECT_SET_F, rank, num_points,& + coord, error) + CALL check("h5sselect_elements_f", error, total_error) + ref(2)%ref(:) = 0 + CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(2), error) + CALL check("h5rcreate_f", error, total_error) + ! + ! Write dataset with the references. + ! + ref_dim(1) = SIZE(ref) + CALL h5dwrite_f(dsetr_id, H5T_STD_REF_DSETREG, ref, ref_dim, error) + CALL check("h5dwrite_f", error, total_error) + ! + ! Close all objects. + ! + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5sclose_f(spacer_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5dclose_f(dsetr_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + ! Reopen the file to test selections. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + CALL h5dopen_f(file_id, dsetnamer, dsetr_id, error) + CALL check("h5dopen_f", error, total_error) + ! + ! Read references to the dataset regions. + ! + ref_dim(1) = SIZE(ref_out) + CALL h5dread_f(dsetr_id, H5T_STD_REF_DSETREG, ref_out, ref_dim, error) + CALL check("h5dread_f", error, total_error) + + ! Get name of the dataset the first region reference points to using H5Rget_name_f + CALL H5Rget_name_f(dsetr_id, ref_out(1), buf, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) + CALL verify("H5Rget_name_f", buf, "/MATRIX", total_error) + + ! Get name of the dataset the first region reference points to using H5Rget_name_f + ! buffer bigger then needed + CALL H5Rget_name_f(dsetr_id, ref_out(1), buf_big, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) + CALL verify("H5Rget_name_f", TRIM(buf_big), "/MATRIX", total_error) + + + ! Get name of the dataset the first region reference points to using H5Rget_name_f + ! buffer smaller then needed + CALL H5Rget_name_f(dsetr_id, ref_out(1), buf_small, error, buf_size ) + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) + CALL verify("H5Rget_name_f", TRIM(buf_small), "/MAT", total_error) + ! + ! Dereference the first reference. + ! + CALL H5rdereference_f(dsetr_id, ref_out(1), dsetv_id, error) + CALL check("h5rdereference_f", error, total_error) + CALL H5rget_region_f(dsetr_id, ref_out(1), space_id, error) + CALL check("h5rget_region_f", error, total_error) + + ! Get name of the dataset the second region reference points to using H5Rget_name_f + CALL H5Rget_name_f(dsetr_id, ref_out(2), buf, error) ! no optional size + CALL check("H5Rget_name_f", error, total_error) + CALL verify("H5Rget_name_f", TRIM(buf), "/MATRIX", total_error) + ! + ! Read selected data from the dataset. + ! + data_dims(1) = 2 + data_dims(2) = 9 + CALL h5dread_f(dsetv_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, & + mem_space_id = space_id, file_space_id = space_id) + CALL check("h5dread_f", error, total_error) + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5dclose_f(dsetv_id, error) + CALL check("h5dclose_f", error, total_error) + data_out = 0 + ! + ! Dereference the second reference. + ! + CALL H5rdereference_f(dsetr_id, ref_out(2), dsetv_id, error) + CALL check("h5rdereference_f", error, total_error) + + CALL H5rget_region_f(dsetr_id, ref_out(2), space_id, error) + CALL check("h5rget_region_f", error, total_error) + ! + ! Read selected data from the dataset. + ! + CALL h5dread_f(dsetv_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, & + mem_space_id = space_id, file_space_id = space_id) + CALL check("h5dread_f", error, total_error) + ! + ! Close all objects + ! + CALL h5sclose_f(space_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5dclose_f(dsetv_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5dclose_f(dsetr_id, error) + CALL check("h5dclose_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 refregtest + +END MODULE TH5R diff --git a/fortran/test/tH5R.f90 b/fortran/test/tH5R.f90 deleted file mode 100644 index ef392b4..0000000 --- a/fortran/test/tH5R.f90 +++ /dev/null @@ -1,483 +0,0 @@ -!****h* root/fortran/test/tH5R.f90 -! -! NAME -! tH5R.f90 -! -! FUNCTION -! Basic testing of Fortran H5R, Reference Interface, APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! NOTES -! Tests h5rcreate_f, h5rdereference_f, h5rget_name_f -! and H5Rget_object_type functions -! -! CONTAINS SUBROUTINES -! refobjtest, refregtest -! -!***** -! -MODULE TH5R - - USE HDF5 - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - -SUBROUTINE refobjtest(cleanup, total_error) - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=9), PARAMETER :: filename = "reference" - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=8), PARAMETER :: dsetnamei = "INTEGERS" - CHARACTER(LEN=17), PARAMETER :: dsetnamer = "OBJECT_REFERENCES" - CHARACTER(LEN=6), PARAMETER :: groupname1 = "GROUP1" - CHARACTER(LEN=6), PARAMETER :: groupname2 = "GROUP2" - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: grp1_id ! Group identifier - INTEGER(HID_T) :: grp2_id ! Group identifier - INTEGER(HID_T) :: dset1_id ! Dataset identifier - INTEGER(HID_T) :: dsetr_id ! Dataset identifier - INTEGER(HID_T) :: type_id ! Type identifier - INTEGER(HID_T) :: space_id ! Dataspace identifier - INTEGER(HID_T) :: spacer_id ! Dataspace identifier - INTEGER :: error, obj_type - INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/5/) - INTEGER(HSIZE_T), DIMENSION(1) :: dimsr= (/4/) - INTEGER(HSIZE_T), DIMENSION(1) :: my_maxdims = (/5/) - INTEGER :: rank = 1 - INTEGER :: rankr = 1 - TYPE(hobj_ref_t_f), DIMENSION(4) :: ref - TYPE(hobj_ref_t_f), DIMENSION(4) :: ref_out - INTEGER(HSIZE_T), DIMENSION(1) :: ref_dim - INTEGER, DIMENSION(5) :: DATA = (/1, 2, 3, 4, 5/) - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - - CHARACTER(LEN=7) :: buf ! buffer to hold the region name - CHARACTER(LEN=16) :: buf_big ! buffer bigger then needed - INTEGER(SIZE_T) :: buf_size ! returned size of the region buffer name - - ! - !Create a new file with Default file access and - !file creation properties . - ! - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - IF (error .NE. 0) THEN - WRITE(*,*) "Cannot modify filename" - STOP - ENDIF - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - CALL check("h5fcreate_f",error,total_error) - - - ! - ! Create a group inside the file - ! - CALL h5gcreate_f(file_id, groupname1, grp1_id, error) - CALL check("h5gcreate_f",error,total_error) - - ! - ! Create a group inside the group GROUP1 - ! - CALL h5gcreate_f(grp1_id, groupname2, grp2_id, error) - CALL check("h5gcreate_f",error,total_error) - - ! - ! Create dataspaces for datasets - ! - CALL h5screate_simple_f(rank, dims, space_id, error, maxdims=my_maxdims) - CALL check("h5screate_simple_f",error,total_error) - CALL h5screate_simple_f(rankr, dimsr, spacer_id, error) - CALL check("h5screate_simple_f",error,total_error) - - ! - ! Create integer dataset - ! - CALL h5dcreate_f(file_id, dsetnamei, H5T_NATIVE_INTEGER, space_id, & - dset1_id, error) - CALL check("h5dcreate_f",error,total_error) - ! - ! Create dataset to store references to the objects - ! - CALL h5dcreate_f(file_id, dsetnamer, H5T_STD_REF_OBJ, spacer_id, & - dsetr_id, error) - CALL check("h5dcreate_f",error,total_error) - ! - ! Create a datatype and store in the file - ! - CALL h5tcopy_f(H5T_NATIVE_REAL, type_id, error) - CALL check("h5tcopy_f",error,total_error) - CALL h5tcommit_f(file_id, "MyType", type_id, error) - CALL check("h5tcommit_f",error,total_error) - ! - ! Close dataspaces, groups and integer dataset - ! - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5sclose_f(spacer_id, error) - CALL check("h5sclose_f",error,total_error) - CALL h5dclose_f(dset1_id, error) - CALL check("h5dclose_f",error,total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f",error,total_error) - CALL h5gclose_f(grp1_id, error) - CALL check("h5gclose_f",error,total_error) - CALL h5gclose_f(grp2_id, error) - CALL check("h5gclose_f",error,total_error) - - ! - ! Craete references to two groups, integer dataset and shared datatype - ! and write it to the dataset in the file - ! - CALL h5rcreate_f(file_id, groupname1, ref(1), error) - CALL check("h5rcreate_f",error,total_error) - CALL h5rcreate_f(file_id, "/GROUP1/GROUP2", ref(2), error) - CALL check("h5rcreate_f",error,total_error) - CALL h5rcreate_f(file_id, dsetnamei, ref(3), error) - CALL check("h5rcreate_f",error,total_error) - CALL h5rcreate_f(file_id, "MyType", ref(4), error) - CALL check("h5rcreate_f",error,total_error) - ref_dim(1) = SIZE(ref) - CALL h5dwrite_f(dsetr_id, H5T_STD_REF_OBJ, ref, ref_dim, error) - CALL check("h5dwrite_f",error,total_error) - - ! getting path to normal dataset in root group - - CALL H5Rget_name_f(dsetr_id, ref(1), buf, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - - - CALL verify("H5Rget_name_f", INT(buf_size),7, total_error) - CALL verify("H5Rget_name_f", buf, "/GROUP1", total_error) - - ! with buffer bigger then needed - - CALL H5Rget_name_f(dsetr_id, ref(1), buf_big, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) - CALL verify("H5Rget_name_f", TRIM(buf_big), "/GROUP1", total_error) - - ! getting path to dataset in /Group1 - - CALL H5Rget_name_f(dsetr_id, ref(2), buf_big, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", INT(buf_size),14,total_error) - CALL verify("H5Rget_name_f", TRIM(buf_big), "/GROUP1/GROUP2", total_error) - - ! - !Close the dataset - ! - CALL h5dclose_f(dsetr_id, error) - CALL check("h5dclose_f",error,total_error) - - ! - ! Reopen the dataset with object references - ! - CALL h5dopen_f(file_id, dsetnamer,dsetr_id,error) - CALL check("h5dopen_f",error,total_error) - ref_dim(1) = SIZE(ref_out) - CALL h5dread_f(dsetr_id, H5T_STD_REF_OBJ, ref_out, ref_dim, error) - CALL check("h5dread_f",error,total_error) - - ! - !get the third reference's type and Dereference it - ! - CALL h5rget_object_type_f(dsetr_id, ref(3), obj_type, error) - CALL check("h5rget_object_type_f",error,total_error) - IF (obj_type == H5G_DATASET_F) THEN - CALL h5rdereference_f(dsetr_id, ref(3), dset1_id, error) - CALL check("h5rdereference_f",error,total_error) - - data_dims(1) = 5 - CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, DATA, data_dims, error) - CALL check("h5dwrite_f",error,total_error) - END IF - - ! - !get the fourth reference's type and Dereference it - ! - CALL h5rget_object_type_f(dsetr_id, ref(4), obj_type, error) - CALL check("h5rget_object_type_f",error,total_error) - IF (obj_type == H5G_TYPE_F) THEN - CALL h5rdereference_f(dsetr_id, ref(4), type_id, error) - CALL check("h5rdereference_f",error,total_error) - END IF - - ! - ! Close all objects. - ! - CALL h5dclose_f(dset1_id, error) - CALL check("h5dclose_f",error,total_error) - CALL h5tclose_f(type_id, error) - CALL check("h5tclose_f",error,total_error) - - CALL h5dclose_f(dsetr_id, error) - CALL check("h5dclose_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 refobjtest -! -! The following subroutine tests h5rget_region_f, h5rcreate_f, h5rget_name_f, -! and h5rdereference_f functionalities -! -SUBROUTINE refregtest(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=6), PARAMETER :: filename = "Refreg" - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=6), PARAMETER :: dsetnamev = "MATRIX" - CHARACTER(LEN=17), PARAMETER :: dsetnamer = "REGION_REFERENCES" - - CHARACTER(LEN=7) :: buf ! buffer to hold the region name - CHARACTER(LEN=11) :: buf_big ! buffer bigger then needed - CHARACTER(LEN=4) :: buf_small ! buffer smaller then needed - INTEGER(SIZE_T) :: buf_size ! returned size of the region buffer name - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: space_id ! Dataspace identifier - INTEGER(HID_T) :: spacer_id ! Dataspace identifier - INTEGER(HID_T) :: dsetv_id ! Dataset identifier - INTEGER(HID_T) :: dsetr_id ! Dataset identifier - INTEGER :: error -! TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2), TARGET :: ref - TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref - TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref_out - INTEGER(HSIZE_T), DIMENSION(2) :: ref_dim = (/0,0/) - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims ! = (/0,0/) - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/2,9/) ! Datasets dimensions - INTEGER(HSIZE_T), DIMENSION(1) :: dimsr = (/2/) ! - INTEGER(HSIZE_T), DIMENSION(2) :: start ! = (/0,0/) - INTEGER(HSIZE_T), DIMENSION(2) :: count ! = (/0,0/) - - INTEGER :: rankr = 1 - INTEGER :: rank = 2 -! INTEGER , DIMENSION(2,9), TARGET :: DATA - INTEGER , DIMENSION(2,9) :: DATA - INTEGER , DIMENSION(2,9) :: data_out = 0 - INTEGER(HSIZE_T) , DIMENSION(2,3) :: coord - INTEGER(SIZE_T) ::num_points = 3 ! Number of selected points -! type(c_ptr) :: f_ptr - coord = RESHAPE((/1,1,2,7,1,9/), (/2,3/)) ! Coordinates of selected points - DATA = RESHAPE ((/1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6/), (/2,9/)) - - ref_out(1)%ref = 0 - ref_out(2)%ref = 0 - - ! - ! Initialize FORTRAN predefined datatypes. - ! - ! CALL h5init_types_f(error) - ! CALL check("h5init_types_f", error, total_error) - ! - ! Create a new file. - ! - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) - IF (error .NE. 0) THEN - WRITE(*,*) "Cannot modify filename" - STOP - ENDIF - CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) - ! Default file access and file creation - ! properties are used. - CALL check("h5fcreate_f", error, total_error) - ! - ! Create dataspaces: - ! - ! for dataset with references to dataset regions - ! - CALL h5screate_simple_f(rankr, dimsr, spacer_id, error) - CALL check("h5screate_simple_f", error, total_error) - ! - ! for integer dataset - ! - CALL h5screate_simple_f(rank, dims, space_id, error) - CALL check("h5screate_simple_f", error, total_error) - ! - ! Create and write datasets: - ! - ! Integer dataset - ! - CALL h5dcreate_f(file_id, dsetnamev, H5T_NATIVE_INTEGER, space_id, & - dsetv_id, error) - CALL check("h5dcreate_f", error, total_error) - data_dims(1) = 2 - data_dims(2) = 9 - -! f_ptr = c_loc(data) -! CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, f_ptr, error) - - CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, DATA, data_dims, error) - CALL check("h5dwrite_f", error, total_error) - - CALL h5dclose_f(dsetv_id, error) - CALL check("h5dclose_f", error, total_error) - - ! - ! Dataset with references - ! - CALL h5dcreate_f(file_id, dsetnamer, H5T_STD_REF_DSETREG, spacer_id, & - dsetr_id, error) - CALL check("h5dcreate_f", error, total_error) - ! - ! Create a reference to the hyperslab selection. - ! - start(1) = 0 - start(2) = 3 - COUNT(1) = 2 - COUNT(2) = 3 - CALL h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, & - start, count, error) - CALL check("h5sselect_hyperslab_f", error, total_error) - ref(1)%ref(:) = 0 -! f_ptr = C_LOC(ref(1)) -! CALL h5rcreate_f(file_id, dsetnamev, 1, space_id, f_ptr, error) - CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(1), error) - CALL check("h5rcreate_f", error, total_error) - - ! - ! Create a reference to elements selection. - ! - CALL h5sselect_none_f(space_id, error) - CALL check("h5sselect_none_f", error, total_error) - CALL h5sselect_elements_f(space_id, H5S_SELECT_SET_F, rank, num_points,& - coord, error) - CALL check("h5sselect_elements_f", error, total_error) - ref(2)%ref(:) = 0 - CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(2), error) - CALL check("h5rcreate_f", error, total_error) - ! - ! Write dataset with the references. - ! - ref_dim(1) = SIZE(ref) - CALL h5dwrite_f(dsetr_id, H5T_STD_REF_DSETREG, ref, ref_dim, error) - CALL check("h5dwrite_f", error, total_error) - ! - ! Close all objects. - ! - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5sclose_f(spacer_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5dclose_f(dsetr_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - - ! - ! Reopen the file to test selections. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - CALL h5dopen_f(file_id, dsetnamer, dsetr_id, error) - CALL check("h5dopen_f", error, total_error) - ! - ! Read references to the dataset regions. - ! - ref_dim(1) = SIZE(ref_out) - CALL h5dread_f(dsetr_id, H5T_STD_REF_DSETREG, ref_out, ref_dim, error) - CALL check("h5dread_f", error, total_error) - - ! Get name of the dataset the first region reference points to using H5Rget_name_f - CALL H5Rget_name_f(dsetr_id, ref_out(1), buf, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) - CALL verify("H5Rget_name_f", buf, "/MATRIX", total_error) - - ! Get name of the dataset the first region reference points to using H5Rget_name_f - ! buffer bigger then needed - CALL H5Rget_name_f(dsetr_id, ref_out(1), buf_big, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) - CALL verify("H5Rget_name_f", TRIM(buf_big), "/MATRIX", total_error) - - - ! Get name of the dataset the first region reference points to using H5Rget_name_f - ! buffer smaller then needed - CALL H5Rget_name_f(dsetr_id, ref_out(1), buf_small, error, buf_size ) - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", INT(buf_size),7,total_error) - CALL verify("H5Rget_name_f", TRIM(buf_small), "/MAT", total_error) - ! - ! Dereference the first reference. - ! - CALL H5rdereference_f(dsetr_id, ref_out(1), dsetv_id, error) - CALL check("h5rdereference_f", error, total_error) - CALL H5rget_region_f(dsetr_id, ref_out(1), space_id, error) - CALL check("h5rget_region_f", error, total_error) - - ! Get name of the dataset the second region reference points to using H5Rget_name_f - CALL H5Rget_name_f(dsetr_id, ref_out(2), buf, error) ! no optional size - CALL check("H5Rget_name_f", error, total_error) - CALL verify("H5Rget_name_f", TRIM(buf), "/MATRIX", total_error) - ! - ! Read selected data from the dataset. - ! - data_dims(1) = 2 - data_dims(2) = 9 - CALL h5dread_f(dsetv_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, & - mem_space_id = space_id, file_space_id = space_id) - CALL check("h5dread_f", error, total_error) - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5dclose_f(dsetv_id, error) - CALL check("h5dclose_f", error, total_error) - data_out = 0 - ! - ! Dereference the second reference. - ! - CALL H5rdereference_f(dsetr_id, ref_out(2), dsetv_id, error) - CALL check("h5rdereference_f", error, total_error) - - CALL H5rget_region_f(dsetr_id, ref_out(2), space_id, error) - CALL check("h5rget_region_f", error, total_error) - ! - ! Read selected data from the dataset. - ! - CALL h5dread_f(dsetv_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, & - mem_space_id = space_id, file_space_id = space_id) - CALL check("h5dread_f", error, total_error) - ! - ! Close all objects - ! - CALL h5sclose_f(space_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5dclose_f(dsetv_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5dclose_f(dsetr_id, error) - CALL check("h5dclose_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 refregtest - -END MODULE TH5R diff --git a/fortran/test/tH5S.F90 b/fortran/test/tH5S.F90 new file mode 100644 index 0000000..7223772 --- /dev/null +++ b/fortran/test/tH5S.F90 @@ -0,0 +1,298 @@ +!****h* root/fortran/test/tH5S.f90 +! +! NAME +! tH5S.f90 +! +! FUNCTION +! Basic testing of Fortran H5S, Dataspace Interface, APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests the following functionalities: +! h5screate_f, h5scopy_f, h5screate_simple_f, h5sis_simple_f, +! h5sget_simple_extent_dims_f,h5sget_simple_extent_ndims_f +! h5sget_simple_extent_npoints_f, h5sget_simple_extent_type_f, +! h5sextent_copy_f, h5sset_extent_simple_f, h5sset_extent_none_f +! +! CONTAINS SUBROUTINES +! dataspace_basic_test +! +!***** +MODULE TH5S + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + + SUBROUTINE dataspace_basic_test(cleanup, total_error) + + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=10), PARAMETER :: filename1 = "basicspace" ! File1 name + CHARACTER(LEN=9), PARAMETER :: filename2 = "copyspace" ! File2 name + CHARACTER(LEN=80) :: fix_filename1 + CHARACTER(LEN=80) :: fix_filename2 + CHARACTER(LEN=9), PARAMETER :: dsetname = "basicdset" ! Dataset name + + INTEGER(HID_T) :: file1_id, file2_id ! File identifiers + INTEGER(HID_T) :: dset1_id, dset2_id ! Dataset identifiers + INTEGER(HID_T) :: space1_id, space2_id ! Dataspace identifiers + + INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/4,6/) ! Dataset dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: maxdims1 = (/4,6/) ! maximum dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: dims2 = (/6,6/) ! Dataset dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: maxdims2 = (/6,6/) ! maximum dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: dimsout, maxdimsout ! dimensions + INTEGER(HSIZE_T) :: npoints !number of elements in the dataspace + + INTEGER :: rank1 = 2 ! Dataspace1 rank + INTEGER :: rank2 = 2 ! Dataspace2 rank + INTEGER :: classtype ! Dataspace class type + + INTEGER, DIMENSION(4,6) :: data1_in, data1_out ! Data input buffers + INTEGER, DIMENSION(6,6) :: data2_in, data2_out ! Data output buffers + INTEGER :: error ! Error flag + + LOGICAL :: flag !flag to test datyspace is simple or not + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + + ! + ! Initialize the dset_data array. + ! + do i = 1, 4 + do j = 1, 6 + data1_in(i,j) = (i-1)*6 + j; + end do + end do + + do i = 1, 6 + do j = 1, 6 + data2_in(i,j) = i*6 + j; + end do + end do + + ! + ! Initialize FORTRAN predefined datatypes. + ! +! CALL h5init_types_f(error) +! CALL check("h5init_types_f", error, total_error) + + ! + ! Create new files using default properties. + ! + CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5fcreate_f(fix_filename1, H5F_ACC_TRUNC_F, file1_id, error) + CALL check("h5fcreate_f", error, total_error) + + CALL h5_fixname_f(filename2, fix_filename2, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5fcreate_f(fix_filename2, H5F_ACC_TRUNC_F, file2_id, error) + CALL check("h5fcreate_f", error, total_error) + + ! + ! Create dataspace for file1. + ! + CALL h5screate_simple_f(rank1, dims1, space1_id, error, maxdims1) + CALL check("h5screate_simple_f", error, total_error) + ! + ! Copy space1_id to space2_id. + ! + CALL h5scopy_f(space1_id, space2_id, error) + CALL check("h5scopy_f", error, total_error) + + ! + !Check whether copied space is simple. + ! + CALL h5sis_simple_f(space2_id, flag, error) + CALL check("h5sissimple_f", error, total_error) + IF (.NOT. flag) write(*,*) "dataspace is not simple type" + + ! + !set the copied space to none. + ! + CALL h5sset_extent_none_f(space2_id, error) + CALL check("h5sset_extent_none_f", error, total_error) + + ! + !copy the extent of space1_id to space2_id. + ! + CALL h5sextent_copy_f(space2_id, space1_id, error) + CALL check("h5sextent_copy_f", error, total_error) + + ! + !get the copied space's dimensions. + ! + CALL h5sget_simple_extent_dims_f(space2_id, dimsout, maxdimsout, error) + CALL check("h5sget_simple_extent_dims_f", error, total_error) + IF ((dimsout(1) .NE. dims1(1)) .OR. (dimsout(2) .NE. dims1(2)) ) THEN + write(*,*)"error occured, copied dims not same" + END IF + + ! + !get the copied space's rank. + ! + CALL h5sget_simple_extent_ndims_f(space2_id, rank2, error) + CALL check("h5sget_simple_extent_ndims_f", error, total_error) + IF (rank2 .NE. rank1) write(*,*)"error occured, copied ranks not same" + + ! + !get the copied space's number of elements. + ! + CALL h5sget_simple_extent_npoints_f(space2_id, npoints, error) + CALL check("h5sget_simple_extent_npoints_f", error, total_error) + IF (npoints .NE. 24) write(*,*)"error occured, number of elements not correct" + + + ! + !get the copied space's class type. + ! + CALL h5sget_simple_extent_type_f(space2_id, classtype, error) + CALL check("h5sget_simple_extent_type_f", error, total_error) + IF (classtype .NE. 1) write(*,*)"class type not H5S_SIMPLE_f" + + ! + !set the copied space to none before extend the dimensions. + ! + CALL h5sset_extent_none_f(space2_id, error) + CALL check("h5sset_extent_none_f", error, total_error) + + ! + !set the copied space to dim2 size. + ! + CALL h5sset_extent_simple_f(space2_id, rank2, dims2, maxdims2, error) + CALL check("h5sset_extent_simple_f", error, total_error) + + ! + !get the copied space's dimensions. + ! + CALL h5sget_simple_extent_dims_f(space2_id, dimsout, maxdimsout, error) + CALL check("h5sget_simple_extent_dims_f", error, total_error) + IF ((dimsout(1) .NE. dims2(1)) .OR. (dimsout(2) .NE. dims2(2)) ) THEN + write(*,*)"error occured, copied dims not same" + END IF + + ! + ! Create the datasets with default properties in two files. + ! + CALL h5dcreate_f(file1_id, dsetname, H5T_NATIVE_INTEGER, space1_id, & + dset1_id, error) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dcreate_f(file2_id, dsetname, H5T_NATIVE_INTEGER, space2_id, & + dset2_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the datasets. + ! + data_dims(1) = 4 + data_dims(2) = 6 + CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, data1_in, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + data_dims(1) = 6 + data_dims(2) = 6 + CALL h5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, data2_in, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + ! + ! Read the first dataset. + ! + data_dims(1) = 4 + data_dims(2) = 6 + CALL h5dread_f(dset1_id, H5T_NATIVE_INTEGER, data1_out, data_dims, error) + CALL check("h5dread_f", error, total_error) + + ! + !Compare the data. + ! + do i = 1, 4 + do j = 1, 6 + IF (data1_out(i,j) .NE. data1_in(i, j)) THEN + write(*, *) "dataset test error occured" + write(*,*) "data read is not the same as the data writen" + END IF + end do + end do + + + ! + ! Read the second dataset. + ! + data_dims(1) = 6 + data_dims(2) = 6 + CALL h5dread_f(dset2_id, H5T_NATIVE_INTEGER, data2_out, data_dims, error) + CALL check("h5dread_f", error, total_error) + + ! + !Compare the data. + ! + do i = 1, 6 + do j = 1, 6 + IF (data2_out(i,j) .NE. data2_in(i, j)) THEN + write(*, *) "dataset test error occured" + write(*,*) "data read is not the same as the data writen" + END IF + end do + end do + + ! + !Close the datasets. + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f", error, total_error) + CALL h5dclose_f(dset2_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + ! Terminate access to the data spaces. + ! + CALL h5sclose_f(space1_id, error) + CALL check("h5sclose_f", error, total_error) + CALL h5sclose_f(space2_id, error) + CALL check("h5sclose_f", error, total_error) + ! + ! Close 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) + + + 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 dataspace_basic_test + +END MODULE TH5S diff --git a/fortran/test/tH5S.f90 b/fortran/test/tH5S.f90 deleted file mode 100644 index 7223772..0000000 --- a/fortran/test/tH5S.f90 +++ /dev/null @@ -1,298 +0,0 @@ -!****h* root/fortran/test/tH5S.f90 -! -! NAME -! tH5S.f90 -! -! FUNCTION -! Basic testing of Fortran H5S, Dataspace Interface, APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! NOTES -! Tests the following functionalities: -! h5screate_f, h5scopy_f, h5screate_simple_f, h5sis_simple_f, -! h5sget_simple_extent_dims_f,h5sget_simple_extent_ndims_f -! h5sget_simple_extent_npoints_f, h5sget_simple_extent_type_f, -! h5sextent_copy_f, h5sset_extent_simple_f, h5sset_extent_none_f -! -! CONTAINS SUBROUTINES -! dataspace_basic_test -! -!***** -MODULE TH5S - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - - SUBROUTINE dataspace_basic_test(cleanup, total_error) - - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(INOUT) :: total_error - - CHARACTER(LEN=10), PARAMETER :: filename1 = "basicspace" ! File1 name - CHARACTER(LEN=9), PARAMETER :: filename2 = "copyspace" ! File2 name - CHARACTER(LEN=80) :: fix_filename1 - CHARACTER(LEN=80) :: fix_filename2 - CHARACTER(LEN=9), PARAMETER :: dsetname = "basicdset" ! Dataset name - - INTEGER(HID_T) :: file1_id, file2_id ! File identifiers - INTEGER(HID_T) :: dset1_id, dset2_id ! Dataset identifiers - INTEGER(HID_T) :: space1_id, space2_id ! Dataspace identifiers - - INTEGER(HSIZE_T), DIMENSION(2) :: dims1 = (/4,6/) ! Dataset dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: maxdims1 = (/4,6/) ! maximum dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: dims2 = (/6,6/) ! Dataset dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: maxdims2 = (/6,6/) ! maximum dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: dimsout, maxdimsout ! dimensions - INTEGER(HSIZE_T) :: npoints !number of elements in the dataspace - - INTEGER :: rank1 = 2 ! Dataspace1 rank - INTEGER :: rank2 = 2 ! Dataspace2 rank - INTEGER :: classtype ! Dataspace class type - - INTEGER, DIMENSION(4,6) :: data1_in, data1_out ! Data input buffers - INTEGER, DIMENSION(6,6) :: data2_in, data2_out ! Data output buffers - INTEGER :: error ! Error flag - - LOGICAL :: flag !flag to test datyspace is simple or not - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - - ! - ! Initialize the dset_data array. - ! - do i = 1, 4 - do j = 1, 6 - data1_in(i,j) = (i-1)*6 + j; - end do - end do - - do i = 1, 6 - do j = 1, 6 - data2_in(i,j) = i*6 + j; - end do - end do - - ! - ! Initialize FORTRAN predefined datatypes. - ! -! CALL h5init_types_f(error) -! CALL check("h5init_types_f", error, total_error) - - ! - ! Create new files using default properties. - ! - CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error) - if (error .ne. 0) then - write(*,*) "Cannot modify filename" - stop - endif - CALL h5fcreate_f(fix_filename1, H5F_ACC_TRUNC_F, file1_id, error) - CALL check("h5fcreate_f", error, total_error) - - CALL h5_fixname_f(filename2, fix_filename2, H5P_DEFAULT_F, error) - if (error .ne. 0) then - write(*,*) "Cannot modify filename" - stop - endif - CALL h5fcreate_f(fix_filename2, H5F_ACC_TRUNC_F, file2_id, error) - CALL check("h5fcreate_f", error, total_error) - - ! - ! Create dataspace for file1. - ! - CALL h5screate_simple_f(rank1, dims1, space1_id, error, maxdims1) - CALL check("h5screate_simple_f", error, total_error) - ! - ! Copy space1_id to space2_id. - ! - CALL h5scopy_f(space1_id, space2_id, error) - CALL check("h5scopy_f", error, total_error) - - ! - !Check whether copied space is simple. - ! - CALL h5sis_simple_f(space2_id, flag, error) - CALL check("h5sissimple_f", error, total_error) - IF (.NOT. flag) write(*,*) "dataspace is not simple type" - - ! - !set the copied space to none. - ! - CALL h5sset_extent_none_f(space2_id, error) - CALL check("h5sset_extent_none_f", error, total_error) - - ! - !copy the extent of space1_id to space2_id. - ! - CALL h5sextent_copy_f(space2_id, space1_id, error) - CALL check("h5sextent_copy_f", error, total_error) - - ! - !get the copied space's dimensions. - ! - CALL h5sget_simple_extent_dims_f(space2_id, dimsout, maxdimsout, error) - CALL check("h5sget_simple_extent_dims_f", error, total_error) - IF ((dimsout(1) .NE. dims1(1)) .OR. (dimsout(2) .NE. dims1(2)) ) THEN - write(*,*)"error occured, copied dims not same" - END IF - - ! - !get the copied space's rank. - ! - CALL h5sget_simple_extent_ndims_f(space2_id, rank2, error) - CALL check("h5sget_simple_extent_ndims_f", error, total_error) - IF (rank2 .NE. rank1) write(*,*)"error occured, copied ranks not same" - - ! - !get the copied space's number of elements. - ! - CALL h5sget_simple_extent_npoints_f(space2_id, npoints, error) - CALL check("h5sget_simple_extent_npoints_f", error, total_error) - IF (npoints .NE. 24) write(*,*)"error occured, number of elements not correct" - - - ! - !get the copied space's class type. - ! - CALL h5sget_simple_extent_type_f(space2_id, classtype, error) - CALL check("h5sget_simple_extent_type_f", error, total_error) - IF (classtype .NE. 1) write(*,*)"class type not H5S_SIMPLE_f" - - ! - !set the copied space to none before extend the dimensions. - ! - CALL h5sset_extent_none_f(space2_id, error) - CALL check("h5sset_extent_none_f", error, total_error) - - ! - !set the copied space to dim2 size. - ! - CALL h5sset_extent_simple_f(space2_id, rank2, dims2, maxdims2, error) - CALL check("h5sset_extent_simple_f", error, total_error) - - ! - !get the copied space's dimensions. - ! - CALL h5sget_simple_extent_dims_f(space2_id, dimsout, maxdimsout, error) - CALL check("h5sget_simple_extent_dims_f", error, total_error) - IF ((dimsout(1) .NE. dims2(1)) .OR. (dimsout(2) .NE. dims2(2)) ) THEN - write(*,*)"error occured, copied dims not same" - END IF - - ! - ! Create the datasets with default properties in two files. - ! - CALL h5dcreate_f(file1_id, dsetname, H5T_NATIVE_INTEGER, space1_id, & - dset1_id, error) - CALL check("h5dcreate_f", error, total_error) - - CALL h5dcreate_f(file2_id, dsetname, H5T_NATIVE_INTEGER, space2_id, & - dset2_id, error) - CALL check("h5dcreate_f", error, total_error) - - ! - ! Write the datasets. - ! - data_dims(1) = 4 - data_dims(2) = 6 - CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, data1_in, data_dims, error) - CALL check("h5dwrite_f", error, total_error) - - data_dims(1) = 6 - data_dims(2) = 6 - CALL h5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, data2_in, data_dims, error) - CALL check("h5dwrite_f", error, total_error) - - ! - ! Read the first dataset. - ! - data_dims(1) = 4 - data_dims(2) = 6 - CALL h5dread_f(dset1_id, H5T_NATIVE_INTEGER, data1_out, data_dims, error) - CALL check("h5dread_f", error, total_error) - - ! - !Compare the data. - ! - do i = 1, 4 - do j = 1, 6 - IF (data1_out(i,j) .NE. data1_in(i, j)) THEN - write(*, *) "dataset test error occured" - write(*,*) "data read is not the same as the data writen" - END IF - end do - end do - - - ! - ! Read the second dataset. - ! - data_dims(1) = 6 - data_dims(2) = 6 - CALL h5dread_f(dset2_id, H5T_NATIVE_INTEGER, data2_out, data_dims, error) - CALL check("h5dread_f", error, total_error) - - ! - !Compare the data. - ! - do i = 1, 6 - do j = 1, 6 - IF (data2_out(i,j) .NE. data2_in(i, j)) THEN - write(*, *) "dataset test error occured" - write(*,*) "data read is not the same as the data writen" - END IF - end do - end do - - ! - !Close the datasets. - ! - CALL h5dclose_f(dset1_id, error) - CALL check("h5dclose_f", error, total_error) - CALL h5dclose_f(dset2_id, error) - CALL check("h5dclose_f", error, total_error) - - ! - ! Terminate access to the data spaces. - ! - CALL h5sclose_f(space1_id, error) - CALL check("h5sclose_f", error, total_error) - CALL h5sclose_f(space2_id, error) - CALL check("h5sclose_f", error, total_error) - ! - ! Close 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) - - - 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 dataspace_basic_test - -END MODULE TH5S diff --git a/fortran/test/tH5Sselect.F90 b/fortran/test/tH5Sselect.F90 new file mode 100644 index 0000000..aeb80e9 --- /dev/null +++ b/fortran/test/tH5Sselect.F90 @@ -0,0 +1,1993 @@ +!****h* root/fortran/test/tH5Sselect.f90 +! +! NAME +! tH5Sselect.f90 +! +! FUNCTION +! Basic testing of Fortran H5S, Selection-related Dataspace Interface, APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! NOTES +! Tests the following functionalities: +! h5sget_select_npoints_f, h5sselect_elements_f, h5sselect_all_f, +! h5sselect_none_f, h5sselect_valid_f, h5sselect_hyperslab_f, +! h5sget_select_bounds_f, h5sget_select_elem_pointlist_f, +! h5sget_select_elem_npoints_f, h5sget_select_hyper_blocklist_f, +! h5sget_select_hyper_nblocks_f, h5sget_select_npoints_f +! +! CONTAINS SUBROUTINES +! test_select_hyperslab, test_select_element, test_basic_select, +! test_select_point, test_select_combine, test_select_bounds +! +! +!***** +MODULE TH5SSELECT + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + + SUBROUTINE test_select_hyperslab(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + CHARACTER(LEN=7), PARAMETER :: filename = "tselect" + CHARACTER(LEN=80) :: fix_filename + + ! + !dataset name is "IntArray" + ! + CHARACTER(LEN=8), PARAMETER :: dsetname = "IntArray" + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dataspace ! Dataspace identifier + INTEGER(HID_T) :: memspace ! memspace identifier + + ! + !Memory space dimensions + ! + INTEGER(HSIZE_T), DIMENSION(3) :: dimsm = (/7,7,3/) + + + ! + !Dataset dimensions + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dimsf = (/5,6/) + + ! + !Size of the hyperslab in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: count = (/3,4/) + + ! + !hyperslab offset in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: offset = (/1,2/) + + ! + !Size of the hyperslab in memory + ! + INTEGER(HSIZE_T), DIMENSION(3) :: count_out = (/3,4,1/) + + ! + !hyperslab offset in memory + ! + INTEGER(HSIZE_T), DIMENSION(3) :: offset_out = (/3,0,0/) + + ! + !data to write + ! + INTEGER, DIMENSION(5,6) :: data + + ! + !output buffer + ! + INTEGER, DIMENSION(7,7,3) :: data_out + + + ! + !dataset space rank + ! + INTEGER :: dsetrank = 2 + + ! + !memspace rank + ! + INTEGER :: memrank = 3 + + + + + ! + !general purpose integer + ! + INTEGER :: i, j + + ! + !flag to check operation success + ! + INTEGER :: error + INTEGER(HSIZE_T), DIMENSION(3) :: data_dims + + + ! + !This writes data to the HDF5 file. + ! + + ! + !data initialization + ! + do i = 1, 5 + do j = 1, 6 + data(i,j) = (i-1) + (j-1); + end do + end do + ! + ! 0, 1, 2, 3, 4, 5 + ! 1, 2, 3, 4, 5, 6 + ! 2, 3, 4, 5, 6, 7 + ! 3, 4, 5, 6, 7, 8 + ! 4, 5, 6, 7, 8, 9 + ! + + ! + !Initialize FORTRAN predifined datatypes + ! +! CALL h5init_types_f(error) +! CALL check("h5init_types_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" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f", error, total_error) + + ! + !Create the data space for the dataset. + ! + CALL h5screate_simple_f(dsetrank, dimsf, dataspace, error) + CALL check("h5screate_simple_f", error, total_error) + + ! + ! Create the dataset with default properties + ! + CALL h5dcreate_f(file_id, dsetname, H5T_STD_I32BE, dataspace, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the dataset + ! + data_dims(1) = 5 + data_dims(2) = 6 + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + !This reads the hyperslab from the sds.h5 file just + !created, into a 2-dimensional plane of the 3-dimensional array. + ! + + ! + !initialize data_out array + ! + ! do i = 1, 7 + ! do j = 1, 7 + ! do k = 1,3 + ! data_out(i,j,k) = 0; + ! end do + ! end do + ! end do + + ! + !Open the file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDONLY_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 dataset's dataspace handle. + ! + CALL h5dget_space_f(dset_id, dataspace, error) + CALL check("h5dget_space_f", error, total_error) + + ! + !Select hyperslab in the dataset. + ! + CALL h5sselect_hyperslab_f(dataspace, H5S_SELECT_SET_F, & + offset, count, error) + CALL check("h5sselect_hyperslab_f", error, total_error) + ! + !create memory dataspace. + ! + CALL h5screate_simple_f(memrank, dimsm, memspace, error) + CALL check("h5screate_simple_f", error, total_error) + + ! + !Select hyperslab in memory. + ! + CALL h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, & + offset_out, count_out, error) + CALL check("h5sselect_hyperslab_f", error, total_error) + + ! + !Read data from hyperslab in the file into the hyperslab in + !memory and display. + ! + data_dims(1) = 7 + data_dims(2) = 7 + data_dims(3) = 3 + CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, data_out, data_dims, error, & + memspace, dataspace) + CALL check("h5dread_f", error, total_error) + + ! + !Display data_out array + ! + !do i = 1, 7 + ! print *, (data_out(i,j,1), j = 1,7) + !end do + + ! 0 0 0 0 0 0 0 + ! 0 0 0 0 0 0 0 + ! 0 0 0 0 0 0 0 + ! 3 4 5 6 0 0 0 + ! 4 5 6 7 0 0 0 + ! 5 6 7 8 0 0 0 + ! 0 0 0 0 0 0 0 + ! + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the memoryspace. + ! + CALL h5sclose_f(memspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close the file. + ! + 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 test_select_hyperslab + + ! + !Subroutine to test element selection + ! + + SUBROUTINE test_select_element(cleanup, total_error) + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + ! + !the dataset1 is stored in file "copy1.h5" + ! + CHARACTER(LEN=13), PARAMETER :: filename1 = "tselect_copy1" + CHARACTER(LEN=80) :: fix_filename1 + + ! + !the dataset2 is stored in file "copy2.h5" + ! + CHARACTER(LEN=13), PARAMETER :: filename2 = "tselect_copy2" + CHARACTER(LEN=80) :: fix_filename2 + ! + !dataset1 name is "Copy1" + ! + CHARACTER(LEN=8), PARAMETER :: dsetname1 = "Copy1" + + ! + !dataset2 name is "Copy2" + ! + CHARACTER(LEN=8), PARAMETER :: dsetname2 = "Copy2" + + ! + !dataset rank + ! + INTEGER, PARAMETER :: RANK = 2 + + ! + !number of points selected + ! + INTEGER(SIZE_T), PARAMETER :: NUMP = 2 + + INTEGER(HID_T) :: file1_id ! File1 identifier + INTEGER(HID_T) :: file2_id ! File2 identifier + INTEGER(HID_T) :: dset1_id ! Dataset1 identifier + INTEGER(HID_T) :: dset2_id ! Dataset2 identifier + INTEGER(HID_T) :: dataspace1 ! Dataspace identifier + INTEGER(HID_T) :: dataspace2 ! Dataspace identifier + INTEGER(HID_T) :: memspace ! memspace identifier + + ! + !Memory space dimensions + ! + INTEGER(HSIZE_T), DIMENSION(1) :: dimsm = (/2/) + + ! + !Dataset dimensions + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dimsf = (/3,4/) + + ! + !Points positions in the file + ! + INTEGER(HSIZE_T), DIMENSION(RANK,NUMP) :: coord + + ! + !data buffers + ! + INTEGER, DIMENSION(3,4) :: buf1, buf2, bufnew + + ! + !value to write + ! + INTEGER, DIMENSION(2) :: val = (/53, 59/) + + ! + !memory rank + ! + INTEGER :: memrank = 1 + + ! + !general purpose integer + ! + INTEGER :: i, j + + ! + !flag to check operation success + ! + INTEGER :: error + INTEGER(HSIZE_T), DIMENSION(3) :: data_dims + + + ! + !Create two files containing identical datasets. Write 0's to one + !and 1's to the other. + ! + + ! + !data initialization + ! + do i = 1, 3 + do j = 1, 4 + buf1(i,j) = 0; + end do + end do + + do i = 1, 3 + do j = 1, 4 + buf2(i,j) = 1; + end do + end do + + ! + !Initialize FORTRAN predifined datatypes + ! +! CALL h5init_types_f(error) +! CALL check("h5init_types_f", error, total_error) + + ! + !Create file1, file2 using default properties. + ! + CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5fcreate_f(fix_filename1, H5F_ACC_TRUNC_F, file1_id, error) + CALL check("h5fcreate_f", error, total_error) + + CALL h5_fixname_f(filename2, fix_filename2, H5P_DEFAULT_F, error) + if (error .ne. 0) then + write(*,*) "Cannot modify filename" + stop + endif + CALL h5fcreate_f(fix_filename2, H5F_ACC_TRUNC_F, file2_id, error) + CALL check("h5fcreate_f", error, total_error) + + ! + !Create the data space for the datasets. + ! + CALL h5screate_simple_f(RANK, dimsf, dataspace1, error) + CALL check("h5screate_simple_f", error, total_error) + + CALL h5screate_simple_f(RANK, dimsf, dataspace2, error) + CALL check("h5screate_simple_f", error, total_error) + + ! + ! Create the datasets with default properties + ! + CALL h5dcreate_f(file1_id, dsetname1, H5T_NATIVE_INTEGER, dataspace1, & + dset1_id, error) + CALL check("h5dcreate_f", error, total_error) + + CALL h5dcreate_f(file2_id, dsetname2, H5T_NATIVE_INTEGER, dataspace2, & + dset2_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the datasets + ! + data_dims(1) = 3 + data_dims(2) = 4 + CALL h5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, buf1, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + CALL h5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, buf2, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + ! + !Close the dataspace for the datasets. + ! + CALL h5sclose_f(dataspace1, error) + CALL check("h5sclose_f", error, total_error) + + CALL h5sclose_f(dataspace2, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the datasets. + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5dclose_f(dset2_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close 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) + + ! + !Open the two files. Select two points in one file, write values to + !those point locations, then do H5Scopy and write the values to the + !other file. Close files. + ! + + ! + !Open the files. + ! + CALL h5fopen_f (fix_filename1, H5F_ACC_RDWR_F, file1_id, error) + CALL check("h5fopen_f", error, total_error) + + CALL h5fopen_f (fix_filename2, H5F_ACC_RDWR_F, file2_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + !Open the datasets. + ! + CALL h5dopen_f(file1_id, dsetname1, dset1_id, error) + CALL check("h5dopen_f", error, total_error) + + CALL h5dopen_f(file2_id, dsetname2, dset2_id, error) + CALL check("h5dopen_f", error, total_error) + + ! + !Get dataset1's dataspace handle. + ! + CALL h5dget_space_f(dset1_id, dataspace1, error) + CALL check("h5dget_space_f", error, total_error) + + ! + !create memory dataspace. + ! + CALL h5screate_simple_f(memrank, dimsm, memspace, error) + CALL check("h5screate_simple_f", error, total_error) + + ! + !Set the selected point positions.Because Fortran array index starts + ! from 1, so add one to the actual select points in C + ! + coord(1,1) = 1 + coord(2,1) = 2 + coord(1,2) = 1 + coord(2,2) = 4 + + ! + !Select the elements in file space + ! + CALL h5sselect_elements_f(dataspace1, H5S_SELECT_SET_F, RANK, NUMP,& + coord, error) + CALL check("h5sselect_elements_f", error, total_error) + + ! + !Write value into the selected points in dataset1 + ! + data_dims(1) = 2 + CALL H5dwrite_f(dset1_id, H5T_NATIVE_INTEGER, val, data_dims, error, & + mem_space_id=memspace, file_space_id=dataspace1) + CALL check("h5dwrite_f", error, total_error) + + ! + !Copy the daspace1 into dataspace2 + ! + CALL h5scopy_f(dataspace1, dataspace2, error) + CALL check("h5scopy_f", error, total_error) + + ! + !Write value into the selected points in dataset2 + ! + CALL H5dwrite_f(dset2_id, H5T_NATIVE_INTEGER, val, data_dims, error, & + mem_space_id=memspace, file_space_id=dataspace2) + CALL check("h5dwrite_f", error, total_error) + + ! + !Close the dataspace for the datasets. + ! + CALL h5sclose_f(dataspace1, error) + CALL check("h5sclose_f", error, total_error) + + CALL h5sclose_f(dataspace2, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the memoryspace. + ! + CALL h5sclose_f(memspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the datasets. + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5dclose_f(dset2_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close 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) + + ! + !Open both files and print the contents of the datasets. + ! + + ! + !Open the files. + ! + CALL h5fopen_f (fix_filename1, H5F_ACC_RDWR_F, file1_id, error) + CALL check("h5fopen_f", error, total_error) + + CALL h5fopen_f (fix_filename2, H5F_ACC_RDWR_F, file2_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + !Open the datasets. + ! + CALL h5dopen_f(file1_id, dsetname1, dset1_id, error) + CALL check("h5dopen_f", error, total_error) + + CALL h5dopen_f(file2_id, dsetname2, dset2_id, error) + CALL check("h5dopen_f", error, total_error) + + ! + !Read dataset1. + ! + data_dims(1) = 3 + data_dims(2) = 4 + CALL h5dread_f(dset1_id, H5T_NATIVE_INTEGER, bufnew, data_dims, error) + CALL check("h5dread_f", error, total_error) + + ! + !Display the data read from dataset "Copy1" + ! + !write(*,*) "The data in dataset Copy1 is: " + !do i = 1, 3 + ! print *, (bufnew(i,j), j = 1,4) + !end do + + ! + !Read dataset2. + ! + CALL h5dread_f(dset2_id, H5T_NATIVE_INTEGER, bufnew, data_dims, error) + CALL check("h5dread_f", error, total_error) + + ! + !Display the data read from dataset "Copy2" + ! + !write(*,*) "The data in dataset Copy2 is: " + !do i = 1, 3 + ! print *, (bufnew(i,j), j = 1,4) + !end do + + ! + !Close the datasets. + ! + CALL h5dclose_f(dset1_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5dclose_f(dset2_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close 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) + + + 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 test_select_element + + + SUBROUTINE test_basic_select(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + ! + !the dataset is stored in file "testselect.h5" + ! + CHARACTER(LEN=10), PARAMETER :: filename = "testselect" + CHARACTER(LEN=80) :: fix_filename + + ! + !dataspace rank + ! + INTEGER, PARAMETER :: RANK = 2 + + ! + !select NUMP_POINTS points from the file + ! + INTEGER(SIZE_T), PARAMETER :: NUMPS = 10 + + ! + !dataset name is "testselect" + ! + CHARACTER(LEN=10), PARAMETER :: dsetname = "testselect" + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dataspace ! Dataspace identifier + + ! + !Dataset dimensions + ! + INTEGER(HSIZE_T), DIMENSION(2) :: dimsf = (/5,6/) + + ! + !Size of the hyperslab in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: count = (/2,2/) + + ! + !hyperslab offset in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: offset = (/0,0/) + + ! + !start block for getting the selected hyperslab + ! + INTEGER(HSIZE_T) :: startblock = 0 + + ! + !start point for getting the selected elements + ! + INTEGER(HSIZE_T) :: startpoint = 0 + + ! + !Stride of the hyperslab in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: stride = (/3,3/) + + ! + !BLock size of the hyperslab in the file + ! + INTEGER(HSIZE_T), DIMENSION(2) :: block = (/2,2/) + + ! + !array to give selected points' coordinations + ! + INTEGER(HSIZE_T), DIMENSION(RANK, NUMPS) :: coord + + + ! + !Number of hyperslabs selected in the current dataspace + ! + INTEGER(HSSIZE_T) :: num_blocks + + ! + !allocatable array for putting a list of hyperslabs + !selected in the current file dataspace + ! + INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: blocklist + + ! + !Number of points selected in the current dataspace + ! + INTEGER(HSSIZE_T) :: num_points + INTEGER(HSIZE_T) :: num1_points + + ! + !allocatable array for putting a list of points + !selected in the current file dataspace + ! + INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: pointlist + + ! + !start and end bounds in the current dataspace selection + ! + INTEGER(HSIZE_T), DIMENSION(RANK) :: startout, endout + + ! + !data to write + ! + INTEGER, DIMENSION(5,6) :: data + + ! + !flag to check operation success + ! + INTEGER :: error + INTEGER(HSIZE_T), DIMENSION(3) :: data_dims + + ! + !initialize the coord array to give the selected points' position + ! + coord(1,1) = 1 + coord(2,1) = 1 + coord(1,2) = 1 + coord(2,2) = 3 + coord(1,3) = 1 + coord(2,3) = 5 + coord(1,4) = 3 + coord(2,4) = 1 + coord(1,5) = 3 + coord(2,5) = 3 + coord(1,6) = 3 + coord(2,6) = 5 + coord(1,7) = 4 + coord(2,7) = 3 + coord(1,8) = 4 + coord(2,8) = 1 + coord(1,9) = 5 + coord(2,9) = 3 + coord(1,10) = 5 + coord(2,10) = 5 + + ! + !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" + stop + endif + CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) + CALL check("h5fcreate_f", error, total_error) + + ! + !Create the data space for the dataset. + ! + CALL h5screate_simple_f(RANK, dimsf, dataspace, error) + CALL check("h5screate_simple_f", error, total_error) + + ! + ! Create the dataset with default properties + ! + CALL h5dcreate_f(file_id, dsetname, H5T_STD_I32BE, dataspace, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the dataset + ! + data_dims(1) = 5 + data_dims(2) = 6 + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, data, data_dims, error) + CALL check("h5dwrite_f", error, total_error) + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_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_RDONLY_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 dataset's dataspace handle. + ! + CALL h5dget_space_f(dset_id, dataspace, error) + CALL check("h5dget_space_f", error, total_error) + + ! + !Select hyperslab in the dataset. + ! + CALL h5sselect_hyperslab_f(dataspace, H5S_SELECT_SET_F, & + offset, count, error, stride, block) + CALL check("h5sselect_hyperslab_f", error, total_error) + + ! + !get the number of hyperslab blocks in the current dataspac selection + ! + CALL h5sget_select_hyper_nblocks_f(dataspace, num_blocks, error) + CALL check("h5sget_select_hyper_nblocks_f", error, total_error) + IF (num_blocks .NE. 4) write (*,*) "error occured with num_blocks" + !write(*,*) num_blocks + !result of num_blocks is 4 + + ! + !allocate the blocklist array + ! + ALLOCATE(blocklist(num_blocks*RANK*2), STAT= error) + if(error .NE. 0) then + STOP + endif + + ! + !get the list of hyperslabs selected in the current dataspac selection + ! + CALL h5sget_select_hyper_blocklist_f(dataspace, startblock, & + num_blocks, blocklist, error) + CALL check("h5sget_select_hyper_blocklist_f", error, total_error) +! write(*,*) (blocklist(i), i =1, num_blocks*RANK*2) + !result of blocklist selected is: + !1, 1, 2, 2, 4, 1, 5, 2, 1, 4, 2, 5, 4, 4, 5, 5 + + ! + !deallocate the blocklist array + ! + DEALLOCATE(blocklist) + + ! + !get the selection bounds in the current dataspac selection + ! + CALL h5sget_select_bounds_f(dataspace, startout, endout, error) + CALL check("h5sget_select_bounds_f", error, total_error) + IF ( (startout(1) .ne. 1) .or. (startout(2) .ne. 1) ) THEN + write(*,*) "error occured to select_bounds's start position" + END IF + + IF ( (endout(1) .ne. 5) .or. (endout(2) .ne. 5) ) THEN + write(*,*) "error occured to select_bounds's end position" + END IF + !write(*,*) (startout(i), i = 1, RANK) + !result of startout is 0, 0 + + !write(*,*) (endout(i), i = 1, RANK) + !result of endout is 5, 5 + + ! + !allocate the pointlist array + ! +! ALLOCATE(pointlist(num_blocks*RANK), STAT= error) + ALLOCATE(pointlist(20), STAT= error) + if(error .NE. 0) then + STOP + endif + + ! + !Select the elements in file space + ! + CALL h5sselect_elements_f(dataspace, H5S_SELECT_SET_F, RANK, NUMPS,& + coord, error) + CALL check("h5sselect_elements_f", error, total_error) + + ! + !Get the number of selected elements + ! + CALL h5sget_select_elem_npoints_f(dataspace, num_points, error) + CALL check("h5sget_select_elem_npoints_f", error, total_error) + IF (num_points .NE. 10) write(*,*) "error occured with num_points" + !write(*,*) num_points + ! result of num_points is 10 + + ! + !Get the list of selected elements + ! + num1_points = num_points + CALL h5sget_select_elem_pointlist_f(dataspace, startpoint, & + num1_points, pointlist, error) + CALL check("h5sget_select_elem_pointlist_f", error, total_error) + !write(*,*) (pointlist(i), i =1, num1_points*RANK) + !result of pintlist is: + !1, 1, 3, 1, 5, 1, 1, 3, 3, 3, 5, 3, 3, + !4, 1, 4, 3, 5, 5, 5 + + ! + !deallocate the pointlist array + ! + DEALLOCATE(pointlist) + + ! + !Close the dataspace for the dataset. + ! + CALL h5sclose_f(dataspace, error) + CALL check("h5sclose_f", error, total_error) + + ! + !Close the dataset. + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + ! + !Close the file. + ! + 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 test_basic_select + +!*************************************************************** +!** +!** test_select_point(): Test basic H5S (dataspace) selection code. +!** Tests element selections between dataspaces of various sizes +!** and dimensionalities. +!** +!*************************************************************** + +SUBROUTINE test_select_point(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + INTEGER(HID_T) :: xfer_plist + + INTEGER, PARAMETER :: SPACE1_DIM1=3 + INTEGER, PARAMETER :: SPACE1_DIM2=15 + INTEGER, PARAMETER :: SPACE1_DIM3=13 + INTEGER, PARAMETER :: SPACE2_DIM1=30 + INTEGER, PARAMETER :: SPACE2_DIM2=26 + INTEGER, PARAMETER :: SPACE3_DIM1=15 + INTEGER, PARAMETER :: SPACE3_DIM2=26 + + INTEGER, PARAMETER :: SPACE1_RANK=3 + INTEGER, PARAMETER :: SPACE2_RANK=2 + INTEGER, PARAMETER :: SPACE3_RANK=2 + + ! Element selection information + INTEGER, PARAMETER :: POINT1_NPOINTS=10 + INTEGER(hid_t) ::fid1 ! HDF5 File IDs + INTEGER(hid_t) ::dataset ! Dataset ID + INTEGER(hid_t) ::sid1,sid2 ! Dataspace ID + INTEGER(hsize_t), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/) + INTEGER(hsize_t), DIMENSION(1:2) :: dims2 = (/SPACE2_DIM1, SPACE2_DIM2/) + INTEGER(hsize_t), DIMENSION(1:2) :: dims3 = (/SPACE3_DIM1, SPACE3_DIM2/) + + INTEGER(hsize_t), DIMENSION(1:SPACE1_RANK,1:POINT1_NPOINTS) :: coord1 ! Coordinates for point selection + INTEGER(hsize_t), DIMENSION(1:SPACE1_RANK,1:POINT1_NPOINTS) :: temp_coord1 ! Coordinates for point selection + INTEGER(hsize_t), DIMENSION(1:SPACE2_RANK,1:POINT1_NPOINTS) :: coord2 ! Coordinates for point selection + INTEGER(hsize_t), DIMENSION(1:SPACE2_RANK,1:POINT1_NPOINTS) :: temp_coord2 ! Coordinates for point selection + INTEGER(hsize_t), DIMENSION(1:SPACE3_RANK,1:POINT1_NPOINTS) :: coord3 ! Coordinates for point selection + INTEGER(hsize_t), DIMENSION(1:SPACE3_RANK,1:POINT1_NPOINTS) :: temp_coord3 ! Coordinates for point selection + INTEGER(hssize_t) :: npoints + +!!$ uint8_t *wbuf, buffer to write to disk +!!$ *rbuf, buffer read from disk +!!$ *tbuf; temporary buffer pointer + INTEGER :: i,j; ! Counters +! struct pnt_iter pi; Custom Pointer iterator struct + INTEGER :: error ! Generic return value + CHARACTER(LEN=9) :: filename = 'h5s_hyper' + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=1), DIMENSION(1:SPACE2_DIM1,1:SPACE2_DIM2) :: wbuf + + CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) + IF (error .NE. 0) THEN + WRITE(*,*) "Cannot modify filename" + STOP + ENDIF + xfer_plist = H5P_DEFAULT_F +! MESSAGE(5, ("Testing Element Selection Functions\n")); + + ! Allocate write & read buffers +!!$ wbuf = HDmalloc(sizeof(uint8_t) * SPACE2_DIM1 * SPACE2_DIM2); +!!$ rbuf = HDcalloc(sizeof(uint8_t), (size_t)(SPACE3_DIM1 * SPACE3_DIM2)); +!!$ + ! Initialize WRITE buffer + + DO i = 1, SPACE2_DIM1 + DO j = 1, SPACE2_DIM2 + wbuf(i,j) = 'a' + ENDDO + ENDDO + +!!$ for(i=0, tbuf=wbuf; i 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 diff --git a/fortran/test/tH5T.f90 b/fortran/test/tH5T.f90 deleted file mode 100644 index efbceea..0000000 --- a/fortran/test/tH5T.f90 +++ /dev/null @@ -1,1149 +0,0 @@ -!****h* root/fortran/test/tH5T.f90 -! -! NAME -! tH5T.f90 -! -! FUNCTION -! Basic testing of Fortran H5T APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. 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 trasfer 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 ! Lenght 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) :: 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" - stop - 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 memebers - ! - ! CHARACTER*2 memeber - ! - 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 memeber 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 memeber 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 memebr" - 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 memebr" - 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 memebr" - 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) - 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 - - 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) - 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) - ! - ! 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) - - USE HDF5 - USE TH5_MISC - 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" - STOP - ENDIF - CALL h5fcreate_f(fix_filename,H5F_ACC_TRUNC_F,file_id,error) - CALL check("h5fcreate_f", error, total_error) - ! - ! Create enumeration datatype with tow 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-define and query functions of floating-point types. -! * test h5tget/set_fields_f. -! * -! * Return: Success: 0 -! * -! * Failure: number of errors -! * -! * Fortran Programmer: M.S. Breitenfeld -! * September 9, 2008 -! * -! * Modifications: -! * -! *------------------------------------------------------------------------- -! - -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" - STOP - 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 diff --git a/fortran/test/tH5VL.F90 b/fortran/test/tH5VL.F90 new file mode 100644 index 0000000..834fbde --- /dev/null +++ b/fortran/test/tH5VL.F90 @@ -0,0 +1,512 @@ +!****h* root/fortran/test/tH5VL.f90 +! +! NAME +! tH5VL.f90 +! +! FUNCTION +! Basic testing of Fortran Variable_length datatypes APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! vl_test_integer, vl_test_real, vl_test_string +! +!***** + +MODULE TH5VL + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + USE TH5_MISC_GEN + +CONTAINS + + SUBROUTINE vl_test_integer(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + CHARACTER(LEN=7), PARAMETER :: filename = "VLtypes" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=5), PARAMETER :: dsetname = "VLint" ! Dataset name + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dspace_id ! Dataspace identifier + INTEGER(HID_T) :: vltype_id ! Datatype identifier + + + INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/6/) ! Dataset dimensions + INTEGER(SIZE_T), DIMENSION(6) :: len ! Elements lengths + INTEGER(SIZE_T), DIMENSION(6) :: len_out + INTEGER :: rank = 1 ! Dataset rank + + INTEGER, DIMENSION(5,6) :: vl_int_data ! Data buffers + INTEGER, DIMENSION(5,6) :: vl_int_data_out ! Data buffers + INTEGER :: error ! Error flag + + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T) :: ih, jh !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/5,6/) + INTEGER(SIZE_T) max_len + + ! + ! Initialize the vl_int_data array. + ! + do i = 1, 6 + do j = 1, 5 + vl_int_data(j,i) = -100 + end do + end do + + do i = 2, 6 + do j = 1, i-1 + vl_int_data(j,i) = i-1 + end do + end do + + do i = 1,6 + len(i) = i-1 + end do + + + ! + ! 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" + stop + 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 the dataset with default properties. + ! + CALL h5tvlen_create_f(H5T_NATIVE_INTEGER, vltype_id, error) + CALL check("h5dvlen_create_f", error, total_error) + + CALL h5dcreate_f(file_id, dsetname, vltype_id, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the dataset. + ! + CALL h5dwrite_vl_f(dset_id, vltype_id, vl_int_data, data_dims, len, error) + CALL check("h5dwrite_int_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) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + ! Open the existing file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + + CALL h5dvlen_get_max_len_f(dset_id, vltype_id, dspace_id, max_len, error) + CALL check("h5dvlen_get_max_len_f", error, total_error) + if(max_len .ne. data_dims(1)) then + total_error = total_error + 1 + write(*,*) "Wrong number of elemets returned by h5dvlen_get_max_len_f" + endif + ! + ! Read the dataset. + ! + CALL h5dread_vl_f(dset_id, vltype_id, vl_int_data_out, data_dims, len_out, & + error, mem_space_id = dspace_id, file_space_id = dspace_id) + CALL check("h5dread_int_f", error, total_error) + do ih = 1, data_dims(2) + do jh = 1, len_out(ih) + if(vl_int_data(jh,ih) .ne. vl_int_data_out(jh,ih)) then + total_error = total_error + 1 + write(*,*) "h5dread_vl_f returned incorrect data" + endif + enddo + if (len(ih) .ne. len_out(ih)) then + total_error = total_error + 1 + write(*,*) "h5dread_vl_f returned incorrect data" + endif + enddo + + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5tclose_f(vltype_id, error) + CALL check("h5tclose_f", error, total_error) + + ! + ! Terminate access to the data space. + ! + CALL h5sclose_f(dspace_id, error) + CALL check("h5sclose_f", error, total_error) + + ! + ! Close the file. + ! + 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 vl_test_integer + + SUBROUTINE vl_test_real(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + CHARACTER(LEN=8), PARAMETER :: filename = "VLtypesR" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=6), PARAMETER :: dsetname = "VLreal" ! Dataset name + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dspace_id ! Dataspace identifier + INTEGER(HID_T) :: vltype_id ! Datatype identifier + + + INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/6/) ! Dataset dimensions + INTEGER(SIZE_T), DIMENSION(6) :: len ! Elements lengths + INTEGER(SIZE_T), DIMENSION(6) :: len_out + INTEGER :: rank = 1 ! Dataset rank + + REAL, DIMENSION(5,6) :: vl_real_data ! Data buffers + REAL, DIMENSION(5,6) :: vl_real_data_out ! Data buffers + INTEGER :: error ! Error flag + + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T) :: ih, jh !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/5,6/) + INTEGER(SIZE_T) max_len + INTEGER(HID_T) :: vl_type_id + LOGICAL :: vl_flag + + ! + ! Initialize the vl_int_data array. + ! + do i = 1, 6 + do j = 1, 5 + vl_real_data(j,i) = -100. + end do + end do + + do i = 2, 6 + do j = 1, i-1 + vl_real_data(j,i) = i-1 + end do + end do + + do i = 1,6 + len(i) = i-1 + end do + + + ! + ! 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" + stop + 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 the dataset with default properties. + ! + CALL h5tvlen_create_f(H5T_NATIVE_REAL, vltype_id, error) + CALL check("h5dvlen_create_f", error, total_error) + + CALL h5dcreate_f(file_id, dsetname, vltype_id, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + CALL h5dget_type_f(dset_id, vl_type_id, error) + CALL check("h5dget_type_f", error, total_error) + CALL h5tis_variable_str_f( vl_type_id, vl_flag, error) + CALL check("h5tis_variable_str_f", error, total_error) + if( vl_flag ) then + write(*,*) "type is wrong" + total_error = total_error + 1 + endif + + + ! + ! Write the dataset. + ! + CALL h5dwrite_vl_f(dset_id, vltype_id, vl_real_data, data_dims, len, error) + CALL check("h5dwrite_vl_real_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) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + ! Open the existing file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + + CALL h5dvlen_get_max_len_f(dset_id, vltype_id, dspace_id, max_len, error) + CALL check("h5dvlen_get_max_len_f", error, total_error) + if(max_len .ne. data_dims(1)) then + total_error = total_error + 1 + write(*,*) "Wrong number of elemets returned by h5dvlen_get_max_len_f" + endif + ! + ! Read the dataset. + ! + CALL h5dread_vl_f(dset_id, vltype_id, vl_real_data_out, data_dims, len_out, & + error, mem_space_id = dspace_id, file_space_id = dspace_id) + CALL check("h5dread_real_f", error, total_error) + DO ih = 1, data_dims(2) + DO jh = 1, len_out(ih) + CALL VERIFY("h5dread_vl_f returned incorrect data",vl_real_data(jh,ih),vl_real_data_out(jh,ih), total_error) + ENDDO + IF (LEN(ih) .NE. len_out(ih)) THEN + total_error = total_error + 1 + WRITE(*,*) "h5dread_vl_f returned incorrect data" + ENDIF + ENDDO + + + ! + CALL h5dclose_f(dset_id, error) + CALL check("h5dclose_f", error, total_error) + + CALL h5tclose_f(vltype_id, error) + CALL check("h5tclose_f", error, total_error) + + ! + ! Terminate access to the data space. + ! + CALL h5sclose_f(dspace_id, error) + CALL check("h5sclose_f", error, total_error) + + ! + ! Close the file. + ! + 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 vl_test_real + + SUBROUTINE vl_test_string(cleanup, total_error) + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + CHARACTER(LEN=8), PARAMETER :: filename = "VLtypesS" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=9), PARAMETER :: dsetname = "VLstrings" ! Dataset name + + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HID_T) :: dset_id ! Dataset identifier + INTEGER(HID_T) :: dspace_id ! Dataspace identifier + + + INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/4/) ! Dataset dimensions + INTEGER(SIZE_T), DIMENSION(4) :: str_len ! Elements lengths + INTEGER(SIZE_T), DIMENSION(4) :: str_len_out + INTEGER :: rank = 1 ! Dataset rank + + CHARACTER(LEN=10), DIMENSION(4) :: string_data ! Array of strings + CHARACTER(LEN=10), DIMENSION(4) :: string_data_out ! Data buffers + INTEGER :: error ! Error flag + + INTEGER(HSIZE_T) :: ih !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/10,4/) + INTEGER(HID_T) :: vl_type_id + LOGICAL :: vl_flag + + ! + ! Initialize the string_data array. + ! + string_data(1) = 'This is ' + str_len(1) = 8 + string_data(2) = 'a fortran ' + str_len(2) = 10 + string_data(3) = 'strings ' + str_len(3) = 8 + string_data(4) = 'test. ' + str_len(4) = 5 + + + ! + ! 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" + stop + 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 the dataset with default properties. + ! + CALL h5dcreate_f(file_id, dsetname, H5T_STRING, dspace_id, & + dset_id, error) + CALL check("h5dcreate_f", error, total_error) + ! + ! Check that dataset has a string datatype + ! + CALL h5dget_type_f(dset_id, vl_type_id, error) + CALL check("h5dget_type_f", error, total_error) + CALL h5tis_variable_str_f( vl_type_id, vl_flag, error) + CALL check("h5tis_variable_str_f", error, total_error) + if( .NOT. vl_flag ) then + write(*,*) "type is wrong" + total_error = total_error + 1 + endif + + ! + ! Write the dataset. + ! + CALL h5dwrite_vl_f(dset_id, H5T_STRING, string_data, data_dims, str_len, error) + CALL check("h5dwrite_string_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) + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + ! Open the existing file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + ! + ! Read the dataset. + ! + CALL h5dread_vl_f(dset_id, H5T_STRING, string_data_out, data_dims, & + str_len_out, error) + CALL check("h5dread_string_f", error, total_error) + do 100 ih = 1, data_dims(2) + if(str_len(ih) .ne. str_len_out(ih)) then + total_error=total_error + 1 + write(*,*) 'Returned string length is incorrect' + goto 100 + endif + if(string_data(1)(1:str_len(ih)) .ne. string_data_out(1)(1:str_len(ih))) then + write(*,*) ' Returned string is wrong' + total_error = total_error + 1 + endif +100 continue + + ! + 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) + + ! + ! Close the file. + ! + 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 vl_test_string +END MODULE TH5VL diff --git a/fortran/test/tH5VL.f90 b/fortran/test/tH5VL.f90 deleted file mode 100644 index 834fbde..0000000 --- a/fortran/test/tH5VL.f90 +++ /dev/null @@ -1,512 +0,0 @@ -!****h* root/fortran/test/tH5VL.f90 -! -! NAME -! tH5VL.f90 -! -! FUNCTION -! Basic testing of Fortran Variable_length datatypes APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! vl_test_integer, vl_test_real, vl_test_string -! -!***** - -MODULE TH5VL - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - USE TH5_MISC_GEN - -CONTAINS - - SUBROUTINE vl_test_integer(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - CHARACTER(LEN=7), PARAMETER :: filename = "VLtypes" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=5), PARAMETER :: dsetname = "VLint" ! Dataset name - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dspace_id ! Dataspace identifier - INTEGER(HID_T) :: vltype_id ! Datatype identifier - - - INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/6/) ! Dataset dimensions - INTEGER(SIZE_T), DIMENSION(6) :: len ! Elements lengths - INTEGER(SIZE_T), DIMENSION(6) :: len_out - INTEGER :: rank = 1 ! Dataset rank - - INTEGER, DIMENSION(5,6) :: vl_int_data ! Data buffers - INTEGER, DIMENSION(5,6) :: vl_int_data_out ! Data buffers - INTEGER :: error ! Error flag - - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T) :: ih, jh !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/5,6/) - INTEGER(SIZE_T) max_len - - ! - ! Initialize the vl_int_data array. - ! - do i = 1, 6 - do j = 1, 5 - vl_int_data(j,i) = -100 - end do - end do - - do i = 2, 6 - do j = 1, i-1 - vl_int_data(j,i) = i-1 - end do - end do - - do i = 1,6 - len(i) = i-1 - end do - - - ! - ! 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" - stop - 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 the dataset with default properties. - ! - CALL h5tvlen_create_f(H5T_NATIVE_INTEGER, vltype_id, error) - CALL check("h5dvlen_create_f", error, total_error) - - CALL h5dcreate_f(file_id, dsetname, vltype_id, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f", error, total_error) - - ! - ! Write the dataset. - ! - CALL h5dwrite_vl_f(dset_id, vltype_id, vl_int_data, data_dims, len, error) - CALL check("h5dwrite_int_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) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - - ! - ! Open the existing file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - - CALL h5dvlen_get_max_len_f(dset_id, vltype_id, dspace_id, max_len, error) - CALL check("h5dvlen_get_max_len_f", error, total_error) - if(max_len .ne. data_dims(1)) then - total_error = total_error + 1 - write(*,*) "Wrong number of elemets returned by h5dvlen_get_max_len_f" - endif - ! - ! Read the dataset. - ! - CALL h5dread_vl_f(dset_id, vltype_id, vl_int_data_out, data_dims, len_out, & - error, mem_space_id = dspace_id, file_space_id = dspace_id) - CALL check("h5dread_int_f", error, total_error) - do ih = 1, data_dims(2) - do jh = 1, len_out(ih) - if(vl_int_data(jh,ih) .ne. vl_int_data_out(jh,ih)) then - total_error = total_error + 1 - write(*,*) "h5dread_vl_f returned incorrect data" - endif - enddo - if (len(ih) .ne. len_out(ih)) then - total_error = total_error + 1 - write(*,*) "h5dread_vl_f returned incorrect data" - endif - enddo - - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - - CALL h5tclose_f(vltype_id, error) - CALL check("h5tclose_f", error, total_error) - - ! - ! Terminate access to the data space. - ! - CALL h5sclose_f(dspace_id, error) - CALL check("h5sclose_f", error, total_error) - - ! - ! Close the file. - ! - 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 vl_test_integer - - SUBROUTINE vl_test_real(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - CHARACTER(LEN=8), PARAMETER :: filename = "VLtypesR" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=6), PARAMETER :: dsetname = "VLreal" ! Dataset name - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dspace_id ! Dataspace identifier - INTEGER(HID_T) :: vltype_id ! Datatype identifier - - - INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/6/) ! Dataset dimensions - INTEGER(SIZE_T), DIMENSION(6) :: len ! Elements lengths - INTEGER(SIZE_T), DIMENSION(6) :: len_out - INTEGER :: rank = 1 ! Dataset rank - - REAL, DIMENSION(5,6) :: vl_real_data ! Data buffers - REAL, DIMENSION(5,6) :: vl_real_data_out ! Data buffers - INTEGER :: error ! Error flag - - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T) :: ih, jh !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/5,6/) - INTEGER(SIZE_T) max_len - INTEGER(HID_T) :: vl_type_id - LOGICAL :: vl_flag - - ! - ! Initialize the vl_int_data array. - ! - do i = 1, 6 - do j = 1, 5 - vl_real_data(j,i) = -100. - end do - end do - - do i = 2, 6 - do j = 1, i-1 - vl_real_data(j,i) = i-1 - end do - end do - - do i = 1,6 - len(i) = i-1 - end do - - - ! - ! 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" - stop - 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 the dataset with default properties. - ! - CALL h5tvlen_create_f(H5T_NATIVE_REAL, vltype_id, error) - CALL check("h5dvlen_create_f", error, total_error) - - CALL h5dcreate_f(file_id, dsetname, vltype_id, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f", error, total_error) - CALL h5dget_type_f(dset_id, vl_type_id, error) - CALL check("h5dget_type_f", error, total_error) - CALL h5tis_variable_str_f( vl_type_id, vl_flag, error) - CALL check("h5tis_variable_str_f", error, total_error) - if( vl_flag ) then - write(*,*) "type is wrong" - total_error = total_error + 1 - endif - - - ! - ! Write the dataset. - ! - CALL h5dwrite_vl_f(dset_id, vltype_id, vl_real_data, data_dims, len, error) - CALL check("h5dwrite_vl_real_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) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - - ! - ! Open the existing file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - - CALL h5dvlen_get_max_len_f(dset_id, vltype_id, dspace_id, max_len, error) - CALL check("h5dvlen_get_max_len_f", error, total_error) - if(max_len .ne. data_dims(1)) then - total_error = total_error + 1 - write(*,*) "Wrong number of elemets returned by h5dvlen_get_max_len_f" - endif - ! - ! Read the dataset. - ! - CALL h5dread_vl_f(dset_id, vltype_id, vl_real_data_out, data_dims, len_out, & - error, mem_space_id = dspace_id, file_space_id = dspace_id) - CALL check("h5dread_real_f", error, total_error) - DO ih = 1, data_dims(2) - DO jh = 1, len_out(ih) - CALL VERIFY("h5dread_vl_f returned incorrect data",vl_real_data(jh,ih),vl_real_data_out(jh,ih), total_error) - ENDDO - IF (LEN(ih) .NE. len_out(ih)) THEN - total_error = total_error + 1 - WRITE(*,*) "h5dread_vl_f returned incorrect data" - ENDIF - ENDDO - - - ! - CALL h5dclose_f(dset_id, error) - CALL check("h5dclose_f", error, total_error) - - CALL h5tclose_f(vltype_id, error) - CALL check("h5tclose_f", error, total_error) - - ! - ! Terminate access to the data space. - ! - CALL h5sclose_f(dspace_id, error) - CALL check("h5sclose_f", error, total_error) - - ! - ! Close the file. - ! - 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 vl_test_real - - SUBROUTINE vl_test_string(cleanup, total_error) - - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - CHARACTER(LEN=8), PARAMETER :: filename = "VLtypesS" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=9), PARAMETER :: dsetname = "VLstrings" ! Dataset name - - INTEGER(HID_T) :: file_id ! File identifier - INTEGER(HID_T) :: dset_id ! Dataset identifier - INTEGER(HID_T) :: dspace_id ! Dataspace identifier - - - INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/4/) ! Dataset dimensions - INTEGER(SIZE_T), DIMENSION(4) :: str_len ! Elements lengths - INTEGER(SIZE_T), DIMENSION(4) :: str_len_out - INTEGER :: rank = 1 ! Dataset rank - - CHARACTER(LEN=10), DIMENSION(4) :: string_data ! Array of strings - CHARACTER(LEN=10), DIMENSION(4) :: string_data_out ! Data buffers - INTEGER :: error ! Error flag - - INTEGER(HSIZE_T) :: ih !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/10,4/) - INTEGER(HID_T) :: vl_type_id - LOGICAL :: vl_flag - - ! - ! Initialize the string_data array. - ! - string_data(1) = 'This is ' - str_len(1) = 8 - string_data(2) = 'a fortran ' - str_len(2) = 10 - string_data(3) = 'strings ' - str_len(3) = 8 - string_data(4) = 'test. ' - str_len(4) = 5 - - - ! - ! 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" - stop - 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 the dataset with default properties. - ! - CALL h5dcreate_f(file_id, dsetname, H5T_STRING, dspace_id, & - dset_id, error) - CALL check("h5dcreate_f", error, total_error) - ! - ! Check that dataset has a string datatype - ! - CALL h5dget_type_f(dset_id, vl_type_id, error) - CALL check("h5dget_type_f", error, total_error) - CALL h5tis_variable_str_f( vl_type_id, vl_flag, error) - CALL check("h5tis_variable_str_f", error, total_error) - if( .NOT. vl_flag ) then - write(*,*) "type is wrong" - total_error = total_error + 1 - endif - - ! - ! Write the dataset. - ! - CALL h5dwrite_vl_f(dset_id, H5T_STRING, string_data, data_dims, str_len, error) - CALL check("h5dwrite_string_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) - - ! - ! Close the file. - ! - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - - ! - ! Open the existing file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - ! - ! Read the dataset. - ! - CALL h5dread_vl_f(dset_id, H5T_STRING, string_data_out, data_dims, & - str_len_out, error) - CALL check("h5dread_string_f", error, total_error) - do 100 ih = 1, data_dims(2) - if(str_len(ih) .ne. str_len_out(ih)) then - total_error=total_error + 1 - write(*,*) 'Returned string length is incorrect' - goto 100 - endif - if(string_data(1)(1:str_len(ih)) .ne. string_data_out(1)(1:str_len(ih))) then - write(*,*) ' Returned string is wrong' - total_error = total_error + 1 - endif -100 continue - - ! - 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) - - ! - ! Close the file. - ! - 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 vl_test_string -END MODULE TH5VL diff --git a/fortran/test/tH5Z.F90 b/fortran/test/tH5Z.F90 new file mode 100644 index 0000000..4201960 --- /dev/null +++ b/fortran/test/tH5Z.F90 @@ -0,0 +1,419 @@ +!****h* root/fortran/test/tH5Z.f90 +! +! NAME +! tH5Z.f90 +! +! FUNCTION +! Basic testing of Fortran H5Z szip APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! filters_test, szip_test +! +!***** +MODULE TH5Z + +CONTAINS + + SUBROUTINE filters_test(total_error) + +! This subroutine tests following functionalities: h5zfilter_avail_f, h5zunregister_f + + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: total_error + LOGICAL :: status + INTEGER(HID_T) :: crtpr_id, xfer_id + INTEGER :: nfilters + INTEGER :: error + INTEGER(HSIZE_T) :: ch_dims(2) + INTEGER :: RANK = 2 + INTEGER :: dlevel = 6 + INTEGER :: edc_flag + + ch_dims(1) = 10 + ch_dims(2) = 3 +! +! Deflate filter +! + CALL h5zfilter_avail_f(H5Z_FILTER_DEFLATE_F, status, error) + CALL check("h5zfilter_avail_f", error, total_error) + if(status) then + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) + CALL check("h5pset_chunk_f",error, total_error) + CALL h5pset_deflate_f(crtpr_id, dlevel, error) + CALL check("h5pset_deflate_f", error, total_error) + CALL h5pclose_f(crtpr_id,error) + CALL check("h5pclose_f", error, total_error) + endif + +! +! Shuffle filter +! + CALL h5zfilter_avail_f(H5Z_FILTER_SHUFFLE_F, status, error) + CALL check("h5zfilter_avail_f", error, total_error) + if(status) then + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) + CALL check("h5pset_chunk_f",error, total_error) + CALL h5pset_shuffle_f(crtpr_id, error) + CALL check("h5pset_shuffle_f", error, total_error) + CALL h5pclose_f(crtpr_id,error) + CALL check("h5pclose_f", error, total_error) + endif + +! +! Checksum filter +! + CALL h5zfilter_avail_f(H5Z_FILTER_FLETCHER32_F, status, error) + CALL check("h5zfilter_avail_f", error, total_error) + if(status) then + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) + CALL check("h5pset_chunk_f",error, total_error) + CALL h5pset_fletcher32_f(crtpr_id, error) + CALL check("h5pset_fletcher32_f", error, total_error) + CALL h5pclose_f(crtpr_id,error) + CALL check("h5pclose_f", error, total_error) + CALL h5pcreate_f(H5P_DATASET_XFER_F, xfer_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_edc_check_f( xfer_id, H5Z_DISABLE_EDC_F, error) + CALL check("h5pset_edc_check_f", error, total_error) + CALL h5pget_edc_check_f( xfer_id, edc_flag, error) + CALL check("h5pget_edc_check_f", error, total_error) + if (edc_flag .ne. H5Z_DISABLE_EDC_F) then + write(*,*) "EDC status is wrong" + total_error = total_error + 1 + endif + CALL h5pclose_f(xfer_id, error) + CALL check("h5pclose_f", error, total_error) + + endif + +! +! Verify h5premove_filter_f +! + CALL h5zfilter_avail_f(H5Z_FILTER_FLETCHER32_F, status, error) + CALL check("h5zfilter_avail_f", error, total_error) + if(status) then + CALL h5zfilter_avail_f(H5Z_FILTER_SHUFFLE_F, status, error) + CALL check("h5zfilter_avail_f", error, total_error) + if(status) then + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) + CALL check("h5pcreate_f", error, total_error) + CALL h5pset_fletcher32_f(crtpr_id, error) + CALL check("h5pset_fletcher32_f", error, total_error) + CALL h5pset_shuffle_f(crtpr_id, error) + CALL check("h5pset_shuffle_f", error, total_error) + CALL h5pget_nfilters_f(crtpr_id, nfilters, error) + CALL check("h5pget_nfilters_f", error, total_error) + + ! Verify the correct number of filters + if (nfilters .ne. 2) then + write(*,*) "number of filters is wrong" + total_error = total_error + 1 + endif + + ! Delete a single filter + CALL h5premove_filter_f(crtpr_id, H5Z_FILTER_SHUFFLE_F, error) + CALL check("h5pset_shuffle_f", error, total_error) + + ! Verify the correct number of filters now + CALL h5pget_nfilters_f(crtpr_id, nfilters, error) + CALL check("h5pget_nfilters_f", error, total_error) + if (nfilters .ne. 1) then + write(*,*) "number of filters is wrong" + total_error = total_error + 1 + endif + + ! Delete all filters + CALL h5premove_filter_f(crtpr_id, H5Z_FILTER_ALL_F, error) + CALL check("h5premove_filter_f", error, total_error) + + ! Verify the correct number of filters now + CALL h5pget_nfilters_f(crtpr_id, nfilters, error) + CALL check("h5pget_nfilters_f", error, total_error) + if (nfilters .ne. 0) then + write(*,*) "number of filters is wrong" + total_error = total_error + 1 + endif + CALL h5pclose_f(crtpr_id,error) + CALL check("h5pclose_f", error, total_error) + endif + endif + + RETURN + END SUBROUTINE filters_test + + SUBROUTINE szip_test(szip_flag, cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + USE TH5_MISC + + IMPLICIT NONE + LOGICAL, INTENT(OUT) :: szip_flag + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + + CHARACTER(LEN=4), PARAMETER :: filename = "szip" ! File name + CHARACTER(LEN=80) :: fix_filename + CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name + INTEGER, PARAMETER :: N = 1024 + INTEGER, PARAMETER :: NN = 64 + INTEGER, PARAMETER :: M = 512 + INTEGER, PARAMETER :: MM = 32 + + 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 ! Datatype identifier + + + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/N,M/) ! Dataset dimensions + INTEGER(HSIZE_T), DIMENSION(2) :: chunk_dims = (/NN, MM/) + INTEGER :: rank = 2 ! Dataset rank + + INTEGER, DIMENSION(N,M) :: dset_data, data_out ! Data buffers + INTEGER :: error ! Error flag + INTEGER :: num_errors = 0 ! Number of data errors + + INTEGER :: i, j !general purpose integers + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + INTEGER(HID_T) :: crp_list + INTEGER :: options_mask, pix_per_block + LOGICAL :: flag + CHARACTER(LEN=4) filter_name + + INTEGER :: filter_flag = -1 + INTEGER(SIZE_T) :: cd_nelemnts = 4 + INTEGER(SIZE_T) :: filter_name_len = 4 + INTEGER, DIMENSION(4) :: cd_values + INTEGER :: config_flag = 0 ! for h5zget_filter_info_f + INTEGER :: config_flag_both = 0 ! for h5zget_filter_info_f + + ! + ! Verify that SZIP exists and has an encoder + ! + CALL h5zfilter_avail_f(H5Z_FILTER_SZIP_F, szip_flag, error) + CALL check("h5zfilter_avail", error, total_error) + + ! Quit if failed + if (error .ne. 0) return + + ! Skip if no SZIP available + if (.NOT. szip_flag)then + return + + else !SZIP available + + ! Continue + CALL h5zget_filter_info_f(H5Z_FILTER_SZIP_F, config_flag, error) + CALL check("h5zget_filter_info_f", error, total_error) + ! Quit if failed + if (error .ne. 0) return + ! + ! Make sure h5zget_filter_info_f returns the right flag + ! + config_flag_both=IOR(H5Z_FILTER_ENCODE_ENABLED_F,H5Z_FILTER_DECODE_ENABLED_F) + if( szip_flag ) then + if (config_flag .NE. config_flag_both) then + if(config_flag .NE. H5Z_FILTER_DECODE_ENABLED_F) then + error = -1 + CALL check("h5zget_filter_info_f config_flag", error, total_error) + endif + endif + endif + + ! Continue only when encoder is available + if ( IAND(config_flag, H5Z_FILTER_ENCODE_ENABLED_F) .EQ. 0 ) return + + options_mask = H5_SZIP_NN_OM_F + pix_per_block = 32 + ! + ! Initialize the dset_data array. + ! + do i = 1, N + do j = 1, M + dset_data(i,j) = (i-1)*6 + j; + end do + end do + + + ! + ! 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" + stop + 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) + + CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) + CALL check("h5pcreat_f",error,total_error) + + CALL h5pset_chunk_f(crp_list, rank, chunk_dims, error) + CALL check("h5pset_chunk_f",error,total_error) + CALL h5pset_szip_f(crp_list, options_mask, pix_per_block, error) + CALL check("h5pset_szip_f",error,total_error) + CALL h5pall_filters_avail_f(crp_list, flag, error) + CALL check("h5pall_filters_avail_f",error,total_error) + if (.NOT. flag) then + CALL h5pclose_f(crp_list, error) + CALL h5sclose_f(dspace_id, error) + CALL h5fclose_f(file_id, error) + szip_flag = .FALSE. + total_error = -1 + return + endif + + CALL h5pget_filter_by_id_f(crp_list, H5Z_FILTER_SZIP_F, filter_flag, & + + cd_nelemnts, cd_values,& + + filter_name_len, filter_name, error) + CALL check("h5pget_filter_by_id_f",error,total_error) + ! + ! Create the dataset with default properties. + ! + CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & + dset_id, error, crp_list) + CALL check("h5dcreate_f", error, total_error) + + ! + ! Write the dataset. + ! + data_dims(1) = N + data_dims(2) = M + CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) + 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) + + ! + ! Close the file. + ! + CALL h5pclose_f(crp_list, error) + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_f", error, total_error) + + ! + ! Open the existing file. + ! + CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) + CALL check("h5fopen_f", error, total_error) + + ! + ! Open the existing dataset. + ! + CALL h5dopen_f(file_id, dsetname, dset_id, error) + CALL check("h5dopen_f", error, total_error) + CALL check("h5pget_filter_by_id_f",error,total_error) + + ! + ! Get the dataset type. + ! + CALL h5dget_type_f(dset_id, dtype_id, error) + CALL check("h5dget_type_f", error, total_error) + + ! + ! Get the data space. + ! + CALL h5dget_space_f(dset_id, dspace_id, error) + CALL check("h5dget_space_f", error, total_error) + + ! + ! 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, N + do j = 1, M + IF (data_out(i,j) .NE. dset_data(i, j)) THEN + write(*, *) "dataset test error occured" + write(*,*) "data read is not the same as the data written" + num_errors = num_errors + 1 + IF (num_errors .GE. 512) THEN + write(*, *) "maximum data errors reached" + goto 100 + END IF + END IF + end do + end do +100 IF (num_errors .GT. 0) THEN + total_error=total_error + 1 + END IF + + ! + ! 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 data type. + ! + CALL h5tclose_f(dtype_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) + if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + endif ! SZIP available + + RETURN + END SUBROUTINE szip_test +END MODULE TH5Z diff --git a/fortran/test/tH5Z.f90 b/fortran/test/tH5Z.f90 deleted file mode 100644 index 4201960..0000000 --- a/fortran/test/tH5Z.f90 +++ /dev/null @@ -1,419 +0,0 @@ -!****h* root/fortran/test/tH5Z.f90 -! -! NAME -! tH5Z.f90 -! -! FUNCTION -! Basic testing of Fortran H5Z szip APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! CONTAINS SUBROUTINES -! filters_test, szip_test -! -!***** -MODULE TH5Z - -CONTAINS - - SUBROUTINE filters_test(total_error) - -! This subroutine tests following functionalities: h5zfilter_avail_f, h5zunregister_f - - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - INTEGER, INTENT(OUT) :: total_error - LOGICAL :: status - INTEGER(HID_T) :: crtpr_id, xfer_id - INTEGER :: nfilters - INTEGER :: error - INTEGER(HSIZE_T) :: ch_dims(2) - INTEGER :: RANK = 2 - INTEGER :: dlevel = 6 - INTEGER :: edc_flag - - ch_dims(1) = 10 - ch_dims(2) = 3 -! -! Deflate filter -! - CALL h5zfilter_avail_f(H5Z_FILTER_DEFLATE_F, status, error) - CALL check("h5zfilter_avail_f", error, total_error) - if(status) then - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) - CALL check("h5pset_chunk_f",error, total_error) - CALL h5pset_deflate_f(crtpr_id, dlevel, error) - CALL check("h5pset_deflate_f", error, total_error) - CALL h5pclose_f(crtpr_id,error) - CALL check("h5pclose_f", error, total_error) - endif - -! -! Shuffle filter -! - CALL h5zfilter_avail_f(H5Z_FILTER_SHUFFLE_F, status, error) - CALL check("h5zfilter_avail_f", error, total_error) - if(status) then - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) - CALL check("h5pset_chunk_f",error, total_error) - CALL h5pset_shuffle_f(crtpr_id, error) - CALL check("h5pset_shuffle_f", error, total_error) - CALL h5pclose_f(crtpr_id,error) - CALL check("h5pclose_f", error, total_error) - endif - -! -! Checksum filter -! - CALL h5zfilter_avail_f(H5Z_FILTER_FLETCHER32_F, status, error) - CALL check("h5zfilter_avail_f", error, total_error) - if(status) then - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_chunk_f(crtpr_id, RANK, ch_dims, error) - CALL check("h5pset_chunk_f",error, total_error) - CALL h5pset_fletcher32_f(crtpr_id, error) - CALL check("h5pset_fletcher32_f", error, total_error) - CALL h5pclose_f(crtpr_id,error) - CALL check("h5pclose_f", error, total_error) - CALL h5pcreate_f(H5P_DATASET_XFER_F, xfer_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_edc_check_f( xfer_id, H5Z_DISABLE_EDC_F, error) - CALL check("h5pset_edc_check_f", error, total_error) - CALL h5pget_edc_check_f( xfer_id, edc_flag, error) - CALL check("h5pget_edc_check_f", error, total_error) - if (edc_flag .ne. H5Z_DISABLE_EDC_F) then - write(*,*) "EDC status is wrong" - total_error = total_error + 1 - endif - CALL h5pclose_f(xfer_id, error) - CALL check("h5pclose_f", error, total_error) - - endif - -! -! Verify h5premove_filter_f -! - CALL h5zfilter_avail_f(H5Z_FILTER_FLETCHER32_F, status, error) - CALL check("h5zfilter_avail_f", error, total_error) - if(status) then - CALL h5zfilter_avail_f(H5Z_FILTER_SHUFFLE_F, status, error) - CALL check("h5zfilter_avail_f", error, total_error) - if(status) then - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crtpr_id, error) - CALL check("h5pcreate_f", error, total_error) - CALL h5pset_fletcher32_f(crtpr_id, error) - CALL check("h5pset_fletcher32_f", error, total_error) - CALL h5pset_shuffle_f(crtpr_id, error) - CALL check("h5pset_shuffle_f", error, total_error) - CALL h5pget_nfilters_f(crtpr_id, nfilters, error) - CALL check("h5pget_nfilters_f", error, total_error) - - ! Verify the correct number of filters - if (nfilters .ne. 2) then - write(*,*) "number of filters is wrong" - total_error = total_error + 1 - endif - - ! Delete a single filter - CALL h5premove_filter_f(crtpr_id, H5Z_FILTER_SHUFFLE_F, error) - CALL check("h5pset_shuffle_f", error, total_error) - - ! Verify the correct number of filters now - CALL h5pget_nfilters_f(crtpr_id, nfilters, error) - CALL check("h5pget_nfilters_f", error, total_error) - if (nfilters .ne. 1) then - write(*,*) "number of filters is wrong" - total_error = total_error + 1 - endif - - ! Delete all filters - CALL h5premove_filter_f(crtpr_id, H5Z_FILTER_ALL_F, error) - CALL check("h5premove_filter_f", error, total_error) - - ! Verify the correct number of filters now - CALL h5pget_nfilters_f(crtpr_id, nfilters, error) - CALL check("h5pget_nfilters_f", error, total_error) - if (nfilters .ne. 0) then - write(*,*) "number of filters is wrong" - total_error = total_error + 1 - endif - CALL h5pclose_f(crtpr_id,error) - CALL check("h5pclose_f", error, total_error) - endif - endif - - RETURN - END SUBROUTINE filters_test - - SUBROUTINE szip_test(szip_flag, cleanup, total_error) - USE HDF5 ! This module contains all necessary modules - USE TH5_MISC - - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: szip_flag - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error - - - CHARACTER(LEN=4), PARAMETER :: filename = "szip" ! File name - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=4), PARAMETER :: dsetname = "dset" ! Dataset name - INTEGER, PARAMETER :: N = 1024 - INTEGER, PARAMETER :: NN = 64 - INTEGER, PARAMETER :: M = 512 - INTEGER, PARAMETER :: MM = 32 - - 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 ! Datatype identifier - - - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/N,M/) ! Dataset dimensions - INTEGER(HSIZE_T), DIMENSION(2) :: chunk_dims = (/NN, MM/) - INTEGER :: rank = 2 ! Dataset rank - - INTEGER, DIMENSION(N,M) :: dset_data, data_out ! Data buffers - INTEGER :: error ! Error flag - INTEGER :: num_errors = 0 ! Number of data errors - - INTEGER :: i, j !general purpose integers - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - INTEGER(HID_T) :: crp_list - INTEGER :: options_mask, pix_per_block - LOGICAL :: flag - CHARACTER(LEN=4) filter_name - - INTEGER :: filter_flag = -1 - INTEGER(SIZE_T) :: cd_nelemnts = 4 - INTEGER(SIZE_T) :: filter_name_len = 4 - INTEGER, DIMENSION(4) :: cd_values - INTEGER :: config_flag = 0 ! for h5zget_filter_info_f - INTEGER :: config_flag_both = 0 ! for h5zget_filter_info_f - - ! - ! Verify that SZIP exists and has an encoder - ! - CALL h5zfilter_avail_f(H5Z_FILTER_SZIP_F, szip_flag, error) - CALL check("h5zfilter_avail", error, total_error) - - ! Quit if failed - if (error .ne. 0) return - - ! Skip if no SZIP available - if (.NOT. szip_flag)then - return - - else !SZIP available - - ! Continue - CALL h5zget_filter_info_f(H5Z_FILTER_SZIP_F, config_flag, error) - CALL check("h5zget_filter_info_f", error, total_error) - ! Quit if failed - if (error .ne. 0) return - ! - ! Make sure h5zget_filter_info_f returns the right flag - ! - config_flag_both=IOR(H5Z_FILTER_ENCODE_ENABLED_F,H5Z_FILTER_DECODE_ENABLED_F) - if( szip_flag ) then - if (config_flag .NE. config_flag_both) then - if(config_flag .NE. H5Z_FILTER_DECODE_ENABLED_F) then - error = -1 - CALL check("h5zget_filter_info_f config_flag", error, total_error) - endif - endif - endif - - ! Continue only when encoder is available - if ( IAND(config_flag, H5Z_FILTER_ENCODE_ENABLED_F) .EQ. 0 ) return - - options_mask = H5_SZIP_NN_OM_F - pix_per_block = 32 - ! - ! Initialize the dset_data array. - ! - do i = 1, N - do j = 1, M - dset_data(i,j) = (i-1)*6 + j; - end do - end do - - - ! - ! 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" - stop - 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) - - CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) - CALL check("h5pcreat_f",error,total_error) - - CALL h5pset_chunk_f(crp_list, rank, chunk_dims, error) - CALL check("h5pset_chunk_f",error,total_error) - CALL h5pset_szip_f(crp_list, options_mask, pix_per_block, error) - CALL check("h5pset_szip_f",error,total_error) - CALL h5pall_filters_avail_f(crp_list, flag, error) - CALL check("h5pall_filters_avail_f",error,total_error) - if (.NOT. flag) then - CALL h5pclose_f(crp_list, error) - CALL h5sclose_f(dspace_id, error) - CALL h5fclose_f(file_id, error) - szip_flag = .FALSE. - total_error = -1 - return - endif - - CALL h5pget_filter_by_id_f(crp_list, H5Z_FILTER_SZIP_F, filter_flag, & - - cd_nelemnts, cd_values,& - - filter_name_len, filter_name, error) - CALL check("h5pget_filter_by_id_f",error,total_error) - ! - ! Create the dataset with default properties. - ! - CALL h5dcreate_f(file_id, dsetname, H5T_NATIVE_INTEGER, dspace_id, & - dset_id, error, crp_list) - CALL check("h5dcreate_f", error, total_error) - - ! - ! Write the dataset. - ! - data_dims(1) = N - data_dims(2) = M - CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, dset_data, data_dims, error) - 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) - - ! - ! Close the file. - ! - CALL h5pclose_f(crp_list, error) - CALL h5fclose_f(file_id, error) - CALL check("h5fclose_f", error, total_error) - - ! - ! Open the existing file. - ! - CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) - CALL check("h5fopen_f", error, total_error) - - ! - ! Open the existing dataset. - ! - CALL h5dopen_f(file_id, dsetname, dset_id, error) - CALL check("h5dopen_f", error, total_error) - CALL check("h5pget_filter_by_id_f",error,total_error) - - ! - ! Get the dataset type. - ! - CALL h5dget_type_f(dset_id, dtype_id, error) - CALL check("h5dget_type_f", error, total_error) - - ! - ! Get the data space. - ! - CALL h5dget_space_f(dset_id, dspace_id, error) - CALL check("h5dget_space_f", error, total_error) - - ! - ! 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, N - do j = 1, M - IF (data_out(i,j) .NE. dset_data(i, j)) THEN - write(*, *) "dataset test error occured" - write(*,*) "data read is not the same as the data written" - num_errors = num_errors + 1 - IF (num_errors .GE. 512) THEN - write(*, *) "maximum data errors reached" - goto 100 - END IF - END IF - end do - end do -100 IF (num_errors .GT. 0) THEN - total_error=total_error + 1 - END IF - - ! - ! 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 data type. - ! - CALL h5tclose_f(dtype_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) - if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - endif ! SZIP available - - RETURN - END SUBROUTINE szip_test -END MODULE TH5Z diff --git a/fortran/test/tHDF5.F90 b/fortran/test/tHDF5.F90 new file mode 100644 index 0000000..d12bb25 --- /dev/null +++ b/fortran/test/tHDF5.F90 @@ -0,0 +1,46 @@ +!****h* ROBODoc/HDF5 +! +! NAME +! MODULE THDF5 +! +! FILE +! src/fortran/test/tHDF5.f90 +! +! PURPOSE +! This is the test module used for testing the Fortran90 HDF library APIs. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +MODULE THDF5 + USE TH5_MISC + USE TH5_MISC_GEN + USE TH5A + USE TH5D + USE TH5E + USE TH5F + USE TH5G + USE TH5I + USE TH5P + USE TH5R + USE TH5S + USE TH5SSELECT + USE TH5T + USE TH5VL + USE TH5Z +END MODULE THDF5 diff --git a/fortran/test/tHDF5.f90 b/fortran/test/tHDF5.f90 deleted file mode 100644 index d12bb25..0000000 --- a/fortran/test/tHDF5.f90 +++ /dev/null @@ -1,46 +0,0 @@ -!****h* ROBODoc/HDF5 -! -! NAME -! MODULE THDF5 -! -! FILE -! src/fortran/test/tHDF5.f90 -! -! PURPOSE -! This is the test module used for testing the Fortran90 HDF library APIs. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -MODULE THDF5 - USE TH5_MISC - USE TH5_MISC_GEN - USE TH5A - USE TH5D - USE TH5E - USE TH5F - USE TH5G - USE TH5I - USE TH5P - USE TH5R - USE TH5S - USE TH5SSELECT - USE TH5T - USE TH5VL - USE TH5Z -END MODULE THDF5 diff --git a/fortran/test/tHDF5_1_8.F90 b/fortran/test/tHDF5_1_8.F90 new file mode 100644 index 0000000..9d1c3ec --- /dev/null +++ b/fortran/test/tHDF5_1_8.F90 @@ -0,0 +1,37 @@ +!****h* ROBODoc/HDF5 +! +! NAME +! MODULE THDF5_1_8 +! +! FILE +! src/fortran/test/tHDF5_1_8.f90 +! +! PURPOSE +! This is the test module used for testing the Fortran90 HDF library +! 1.8.* APIs +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +MODULE THDF5_1_8 + USE TH5_MISC + USE TH5MISC_1_8 + USE TH5A_1_8 + USE TH5G_1_8 + USE TH5O +END MODULE THDF5_1_8 diff --git a/fortran/test/tHDF5_1_8.f90 b/fortran/test/tHDF5_1_8.f90 deleted file mode 100644 index 9d1c3ec..0000000 --- a/fortran/test/tHDF5_1_8.f90 +++ /dev/null @@ -1,37 +0,0 @@ -!****h* ROBODoc/HDF5 -! -! NAME -! MODULE THDF5_1_8 -! -! FILE -! src/fortran/test/tHDF5_1_8.f90 -! -! PURPOSE -! This is the test module used for testing the Fortran90 HDF library -! 1.8.* APIs -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -MODULE THDF5_1_8 - USE TH5_MISC - USE TH5MISC_1_8 - USE TH5A_1_8 - USE TH5G_1_8 - USE TH5O -END MODULE THDF5_1_8 diff --git a/fortran/test/tHDF5_F03.F90 b/fortran/test/tHDF5_F03.F90 new file mode 100644 index 0000000..3dbec11 --- /dev/null +++ b/fortran/test/tHDF5_F03.F90 @@ -0,0 +1,39 @@ +!****h* ROBODoc/HDF5 +! +! NAME +! MODULE THDF5_F03 +! +! FILE +! src/fortran/test/tHDF5_F03.f90 +! +! PURPOSE +! This is the test module used for testing the Fortran2003 HDF +! library APIS. +! +! 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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +!***** + +MODULE THDF5_F03 + USE TH5_MISC + USE TH5E_F03 + USE TH5F_F03 + USE TH5L_F03 + USE TH5O_F03 + USE TH5P_F03 + USE TH5T_F03 +END MODULE THDF5_F03 diff --git a/fortran/test/tHDF5_F03.f90 b/fortran/test/tHDF5_F03.f90 deleted file mode 100644 index 3dbec11..0000000 --- a/fortran/test/tHDF5_F03.f90 +++ /dev/null @@ -1,39 +0,0 @@ -!****h* ROBODoc/HDF5 -! -! NAME -! MODULE THDF5_F03 -! -! FILE -! src/fortran/test/tHDF5_F03.f90 -! -! PURPOSE -! This is the test module used for testing the Fortran2003 HDF -! library APIS. -! -! 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 files COPYING and Copyright.html. COPYING can be found at the root * -! of the source code distribution tree; Copyright.html can be found at the * -! root level of an installed copy of the electronic HDF5 document set and * -! is linked from the top-level documents page. It can also be found at * -! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * -! access to either file, you may request a copy from help@hdfgroup.org. * -! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -!***** - -MODULE THDF5_F03 - USE TH5_MISC - USE TH5E_F03 - USE TH5F_F03 - USE TH5L_F03 - USE TH5O_F03 - USE TH5P_F03 - USE TH5T_F03 -END MODULE THDF5_F03 diff --git a/fortran/testpar/Makefile.in b/fortran/testpar/Makefile.in index 9ee38d5..8f4b815 100644 --- a/fortran/testpar/Makefile.in +++ b/fortran/testpar/Makefile.in @@ -463,6 +463,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/Makefile.in b/hl/Makefile.in index f1e178d..b2309d8 100644 --- a/hl/Makefile.in +++ b/hl/Makefile.in @@ -462,6 +462,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/c++/Makefile.in b/hl/c++/Makefile.in index 7f71fc3..82177b4 100644 --- a/hl/c++/Makefile.in +++ b/hl/c++/Makefile.in @@ -458,6 +458,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/c++/examples/Makefile.in b/hl/c++/examples/Makefile.in index fc3237a..00c53d8 100644 --- a/hl/c++/examples/Makefile.in +++ b/hl/c++/examples/Makefile.in @@ -405,6 +405,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/c++/src/Makefile.in b/hl/c++/src/Makefile.in index 13602bb..9663130 100644 --- a/hl/c++/src/Makefile.in +++ b/hl/c++/src/Makefile.in @@ -461,6 +461,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/c++/test/Makefile.in b/hl/c++/test/Makefile.in index c22eff8..1fab9a5 100644 --- a/hl/c++/test/Makefile.in +++ b/hl/c++/test/Makefile.in @@ -458,6 +458,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/examples/Makefile.in b/hl/examples/Makefile.in index 1061124..b9ede6f 100644 --- a/hl/examples/Makefile.in +++ b/hl/examples/Makefile.in @@ -405,6 +405,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/fortran/Makefile.in b/hl/fortran/Makefile.in index bd2ac82..304a3b6 100644 --- a/hl/fortran/Makefile.in +++ b/hl/fortran/Makefile.in @@ -462,6 +462,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/fortran/examples/Makefile.in b/hl/fortran/examples/Makefile.in index c992e8a..21ff588 100644 --- a/hl/fortran/examples/Makefile.in +++ b/hl/fortran/examples/Makefile.in @@ -410,6 +410,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/fortran/src/CMakeLists.txt b/hl/fortran/src/CMakeLists.txt index 064eb7c..ead21be 100644 --- a/hl/fortran/src/CMakeLists.txt +++ b/hl/fortran/src/CMakeLists.txt @@ -38,17 +38,16 @@ set_target_properties (H5HL_buildiface PROPERTIES if (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) if (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/shared/\${BUILD_TYPE}) + set (MODSH_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/shared/\${BUILD_TYPE}) else (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/shared) - endif (WIN32) -else (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) - if (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static/\${BUILD_TYPE}) - else (WIN32) - set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static) + set (MODSH_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/shared) endif (WIN32) endif (BUILD_SHARED_LIBS AND NOT SKIP_HDF5_FORTRAN_SHARED) +if (WIN32) + set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static/\${BUILD_TYPE}) +else (WIN32) + set (MOD_BUILD_DIR ${CMAKE_Fortran_MODULE_DIRECTORY}/static) +endif (WIN32) #----------------------------------------------------------------------------- # Setup include Directories diff --git a/hl/fortran/src/H5HL_buildiface.F90 b/hl/fortran/src/H5HL_buildiface.F90 index 0e85e27..9dd879c 100644 --- a/hl/fortran/src/H5HL_buildiface.F90 +++ b/hl/fortran/src/H5HL_buildiface.F90 @@ -83,13 +83,13 @@ PROGRAM H5HL_buildiface /) ! pointer to the buffer CHARACTER(LEN=37), DIMENSION(1:8), PARAMETER :: f_ptr_line=(/ & - ' f_ptr = C_LOC(buf) ', & - ' f_ptr = C_LOC(buf(1)) ', & - ' f_ptr = C_LOC(buf(1,1)) ', & - ' f_ptr = C_LOC(buf(1,1,1)) ', & - ' f_ptr = C_LOC(buf(1,1,1,1)) ', & - ' f_ptr = C_LOC(buf(1,1,1,1,1)) ', & - ' f_ptr = C_LOC(buf(1,1,1,1,1,1)) ', & + ' f_ptr = C_LOC(buf )', & + ' f_ptr = C_LOC(buf(1) )', & + ' f_ptr = C_LOC(buf(1,1) )', & + ' f_ptr = C_LOC(buf(1,1,1) )', & + ' f_ptr = C_LOC(buf(1,1,1,1) )', & + ' f_ptr = C_LOC(buf(1,1,1,1,1) )', & + ' f_ptr = C_LOC(buf(1,1,1,1,1,1) )', & ' f_ptr = C_LOC(buf(1,1,1,1,1,1,1))' & /) @@ -154,6 +154,13 @@ PROGRAM H5HL_buildiface WRITE(11,'(A)') " MODULE PROCEDURE h5ltmake_dataset_real_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO + DO i = 1, num_ikinds + j = ikind(i) + WRITE(chr2,'(I2)') j + DO k = 1, 8 + WRITE(11,'(A)') " MODULE PROCEDURE h5ltmake_dataset_integer_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) + ENDDO + END DO WRITE(11,'(A)') " END INTERFACE" ! h5ltread_dataset_f @@ -165,6 +172,35 @@ PROGRAM H5HL_buildiface WRITE(11,'(A)') " MODULE PROCEDURE h5ltread_dataset_real_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO + DO i = 1, num_ikinds + j = ikind(i) + WRITE(chr2,'(I2)') j + DO k = 1, 8 + WRITE(11,'(A)') " MODULE PROCEDURE h5ltread_dataset_integer_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) + ENDDO + END DO + WRITE(11,'(A)') " END INTERFACE" + +! h5ltread_dataset_int_f + WRITE(11,'(A)') " INTERFACE h5ltread_dataset_int_f" + DO i = 1, num_ikinds + j = ikind(i) + WRITE(chr2,'(I2)') j + DO k = 1, 8 + WRITE(11,'(A)') " MODULE PROCEDURE h5ltread_dataset_int_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) + ENDDO + END DO + WRITE(11,'(A)') " END INTERFACE" + +! h5ltmake_dataset_int_f + WRITE(11,'(A)') " INTERFACE h5ltmake_dataset_int_f" + DO i = 1, num_ikinds + j = ikind(i) + WRITE(chr2,'(I2)') j + DO k = 1, 8 + WRITE(11,'(A)') " MODULE PROCEDURE h5ltmake_dataset_int_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) + ENDDO + END DO WRITE(11,'(A)') " END INTERFACE" ! h5ltmake_dataset_float_f @@ -346,7 +382,6 @@ PROGRAM H5HL_buildiface k = rkind(i) WRITE(chr2,'(I2)') k DO j = 1, 8 - ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_HL_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5ltmake_dataset_double_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) @@ -402,6 +437,134 @@ PROGRAM H5HL_buildiface ENDDO ENDDO +! h5ltmake_dataset_f + DO i = 1, num_ikinds + k = ikind(i) + WRITE(chr2,'(I2)') k + DO j = 1, 8 + +! DLL definitions for windows + WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_HL_DLL)' + WRITE(11,'(A)') '!DEC$attributes dllexport :: h5ltmake_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + WRITE(11,'(A)') '!DEC$endif' + +! Subroutine API + WRITE(11,'(A)') ' SUBROUTINE h5ltmake_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))& + &//'_rank'//chr_rank(j)//'(loc_id,dset_name,rank,dims,type_id,buf,errcode)' + WRITE(11,'(A)') ' IMPLICIT NONE' + WRITE(11,'(A)') ' INTEGER(hid_t) , INTENT(IN) :: loc_id' + WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: dset_name' + WRITE(11,'(A)') ' INTEGER, INTENT(IN) :: rank' + WRITE(11,'(A)') ' INTEGER(hsize_t), DIMENSION(*), INTENT(in) :: dims' + WRITE(11,'(A)') ' INTEGER(hid_t), INTENT(in) :: type_id' + WRITE(11,'(A)') ' INTEGER(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' + WRITE(11,'(A)') ' INTEGER :: errcode ' + WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' + WRITE(11,'(A)') ' INTEGER(size_t) :: namelen' + + WRITE(11,'(A)') f_ptr_line(j) + WRITE(11,'(A)') ' namelen = LEN(dset_name)' + WRITE(11,'(A)') ' errcode = h5ltmake_dataset_c(loc_id, namelen, dset_name, rank, dims, type_id, f_ptr)' + WRITE(11,'(A)') ' END SUBROUTINE h5ltmake_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + ENDDO + ENDDO + +! h5ltmake_dataset_int_f + DO i = 1, num_ikinds + k = ikind(i) + WRITE(chr2,'(I2)') k + DO j = 1, 8 + +! DLL definitions for windows + WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_HL_DLL)' + WRITE(11,'(A)') '!DEC$attributes dllexport :: h5ltmake_dataset_int_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + WRITE(11,'(A)') '!DEC$endif' + +! Subroutine API + WRITE(11,'(A)') ' SUBROUTINE h5ltmake_dataset_int_kind_'//TRIM(ADJUSTL(chr2))& + &//'_rank'//chr_rank(j)//'(loc_id,dset_name,rank,dims,buf,errcode)' + WRITE(11,'(A)') ' IMPLICIT NONE' + WRITE(11,'(A)') ' INTEGER(hid_t) , INTENT(IN) :: loc_id' + WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: dset_name' + WRITE(11,'(A)') ' INTEGER, INTENT(IN) :: rank' + WRITE(11,'(A)') ' INTEGER(hsize_t), DIMENSION(*), INTENT(in) :: dims' + WRITE(11,'(A)') ' INTEGER(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' + WRITE(11,'(A)') ' INTEGER :: errcode ' + WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' + WRITE(11,'(A)') ' INTEGER(size_t) :: namelen' + WRITE(11,'(A)') ' INTEGER(hid_t) :: type_id' + + WRITE(11,'(A)') f_ptr_line(j) + WRITE(11,'(A)') ' namelen = LEN(dset_name)' + WRITE(11,'(A)') ' type_id = h5kind_to_type(KIND('//f_ptr_line(j)(19:36)//'), H5_INTEGER_KIND)' + WRITE(11,'(A)') ' errcode = h5ltmake_dataset_c(loc_id, namelen, dset_name, rank, dims, type_id, f_ptr)' + WRITE(11,'(A)') ' END SUBROUTINE h5ltmake_dataset_int_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + ENDDO + ENDDO + +! h5ltread_dataset_f + DO i = 1, num_ikinds + k = ikind(i) + WRITE(chr2,'(I2)') k + DO j = 1, 8 + +! DLL definitions for windows + WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_HL_DLL)' + WRITE(11,'(A)') '!DEC$attributes dllexport :: h5ltread_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + WRITE(11,'(A)') '!DEC$endif' + +! Subroutine API + WRITE(11,'(A)') ' SUBROUTINE h5ltread_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))& + &//'_rank'//chr_rank(j)//'(loc_id,dset_name, type_id, buf,dims,errcode)' + WRITE(11,'(A)') ' IMPLICIT NONE' + WRITE(11,'(A)') ' INTEGER(hid_t) , INTENT(IN) :: loc_id' + WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: dset_name' + WRITE(11,'(A)') ' INTEGER(hsize_t), DIMENSION(*), INTENT(in) :: dims' + WRITE(11,'(A)') ' INTEGER(hid_t), INTENT(in) :: type_id' + WRITE(11,'(A)') ' INTEGER(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' + WRITE(11,'(A)') ' INTEGER :: errcode ' + WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' + WRITE(11,'(A)') ' INTEGER(size_t) :: namelen' + + WRITE(11,'(A)') f_ptr_line(j) + WRITE(11,'(A)') ' namelen = LEN(dset_name)' + WRITE(11,'(A)') ' errcode = h5ltread_dataset_c(loc_id, namelen, dset_name, type_id, f_ptr)' + WRITE(11,'(A)') ' END SUBROUTINE h5ltread_dataset_integer_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + ENDDO + ENDDO + +! h5ltread_dataset_int_f + DO i = 1, num_ikinds + k = ikind(i) + WRITE(chr2,'(I2)') k + DO j = 1, 8 + +! DLL definitions for windows + WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_HL_DLL)' + WRITE(11,'(A)') '!DEC$attributes dllexport :: h5ltread_dataset_int_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + WRITE(11,'(A)') '!DEC$endif' + +! Subroutine API + WRITE(11,'(A)') ' SUBROUTINE h5ltread_dataset_int_kind_'//TRIM(ADJUSTL(chr2))& + &//'_rank'//chr_rank(j)//'(loc_id,dset_name, buf,dims,errcode)' + WRITE(11,'(A)') ' IMPLICIT NONE' + WRITE(11,'(A)') ' INTEGER(hid_t) , INTENT(IN) :: loc_id' + WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: dset_name' + WRITE(11,'(A)') ' INTEGER(hsize_t), DIMENSION(*), INTENT(in) :: dims' + WRITE(11,'(A)') ' INTEGER(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' + WRITE(11,'(A)') ' INTEGER :: errcode ' + WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' + WRITE(11,'(A)') ' INTEGER(size_t) :: namelen' + WRITE(11,'(A)') ' INTEGER(hid_t) :: type_id' + + WRITE(11,'(A)') f_ptr_line(j) + WRITE(11,'(A)') ' namelen = LEN(dset_name)' + WRITE(11,'(A)') ' type_id = h5kind_to_type(KIND('//f_ptr_line(j)(19:36)//'), H5_INTEGER_KIND)' + WRITE(11,'(A)') ' errcode = h5ltread_dataset_c(loc_id, namelen, dset_name, type_id, f_ptr)' + WRITE(11,'(A)') ' END SUBROUTINE h5ltread_dataset_int_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) + ENDDO + ENDDO + WRITE(11,'(A)') 'END MODULE H5LT' ! change this to be generic MSB CLOSE(11) diff --git a/hl/fortran/src/H5LTff.F90 b/hl/fortran/src/H5LTff.F90 index ffc7ab5..d36d92c 100644 --- a/hl/fortran/src/H5LTff.F90 +++ b/hl/fortran/src/H5LTff.F90 @@ -38,47 +38,13 @@ MODULE H5LT_CONST USE hdf5 INTERFACE h5ltmake_dataset_f - MODULE PROCEDURE h5ltmake_dataset_f_int1 - MODULE PROCEDURE h5ltmake_dataset_f_int2 - MODULE PROCEDURE h5ltmake_dataset_f_int3 - MODULE PROCEDURE h5ltmake_dataset_f_int4 - MODULE PROCEDURE h5ltmake_dataset_f_int5 - MODULE PROCEDURE h5ltmake_dataset_f_int6 - MODULE PROCEDURE h5ltmake_dataset_f_int7 MODULE PROCEDURE h5ltmake_dataset_f_ptr END INTERFACE INTERFACE h5ltread_dataset_f - MODULE PROCEDURE h5ltread_dataset_f_int1 - MODULE PROCEDURE h5ltread_dataset_f_int2 - MODULE PROCEDURE h5ltread_dataset_f_int3 - MODULE PROCEDURE h5ltread_dataset_f_int4 - MODULE PROCEDURE h5ltread_dataset_f_int5 - MODULE PROCEDURE h5ltread_dataset_f_int6 - MODULE PROCEDURE h5ltread_dataset_f_int7 MODULE PROCEDURE h5ltread_dataset_f_ptr END INTERFACE - INTERFACE h5ltmake_dataset_int_f - MODULE PROCEDURE h5ltmake_dataset_int_f_1 - MODULE PROCEDURE h5ltmake_dataset_int_f_2 - MODULE PROCEDURE h5ltmake_dataset_int_f_3 - MODULE PROCEDURE h5ltmake_dataset_int_f_4 - MODULE PROCEDURE h5ltmake_dataset_int_f_5 - MODULE PROCEDURE h5ltmake_dataset_int_f_6 - MODULE PROCEDURE h5ltmake_dataset_int_f_7 - END INTERFACE - - INTERFACE h5ltread_dataset_int_f - MODULE PROCEDURE h5ltread_dataset_int_f_1 - MODULE PROCEDURE h5ltread_dataset_int_f_2 - MODULE PROCEDURE h5ltread_dataset_int_f_3 - MODULE PROCEDURE h5ltread_dataset_int_f_4 - MODULE PROCEDURE h5ltread_dataset_int_f_5 - MODULE PROCEDURE h5ltread_dataset_int_f_6 - MODULE PROCEDURE h5ltread_dataset_int_f_7 - END INTERFACE - INTERFACE INTEGER FUNCTION h5ltmake_dataset_c(loc_id,namelen,dset_name,rank,dims,type_id,buf) & BIND(C,NAME='h5ltmake_dataset_c') diff --git a/hl/fortran/src/Makefile.in b/hl/fortran/src/Makefile.in index 5f10a92..9a893be 100644 --- a/hl/fortran/src/Makefile.in +++ b/hl/fortran/src/Makefile.in @@ -489,6 +489,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/fortran/test/Makefile.in b/hl/fortran/test/Makefile.in index da46790..117faf2 100644 --- a/hl/fortran/test/Makefile.in +++ b/hl/fortran/test/Makefile.in @@ -472,6 +472,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/fortran/test/tstlite.F90 b/hl/fortran/test/tstlite.F90 index 0eb005b..0ba7815 100644 --- a/hl/fortran/test/tstlite.F90 +++ b/hl/fortran/test/tstlite.F90 @@ -19,7 +19,7 @@ #include PROGRAM lite_test - + CALL test_dataset1D() CALL test_dataset2D() CALL test_dataset3D() @@ -38,149 +38,148 @@ END PROGRAM lite_test !------------------------------------------------------------------------- SUBROUTINE test_dataset1D() + + USE, INTRINSIC :: ISO_C_BINDING + USE H5LT ! module of H5LT + USE HDF5 ! module of HDF5 library + + IMPLICIT NONE + + INTEGER, PARAMETER :: DIM1 = 4 ! Dimension of array + CHARACTER(len=9), PARAMETER :: filename = "dsetf1.h5"! File name + CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/DIM1/) ! Dataset dimensions + INTEGER :: rank = 1 ! Dataset rank + INTEGER, DIMENSION(DIM1) :: buf1 ! Data buffer + INTEGER, DIMENSION(DIM1) :: bufr1 ! Data buffer + REAL, DIMENSION(DIM1) :: buf2 ! Data buffer + REAL, DIMENSION(DIM1) :: bufr2 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: buf3 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: bufr3 ! Data buffer + INTEGER :: errcode ! Error flag + INTEGER :: i ! general purpose integer + TYPE(C_PTR) :: f_ptr + integer(HID_T) :: mytype -USE, INTRINSIC :: ISO_C_BINDING -USE H5LT ! module of H5LT -USE HDF5 ! module of HDF5 library - -IMPLICIT NONE - -INTEGER, PARAMETER :: DIM1 = 4; ! Dimension of array -CHARACTER(len=9), PARAMETER :: filename = "dsetf1.h5"! File name -CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name -INTEGER(HID_T) :: file_id ! File identifier -INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/DIM1/) ! Dataset dimensions -INTEGER :: rank = 1 ! Dataset rank -INTEGER, DIMENSION(DIM1) :: buf1 ! Data buffer -INTEGER, DIMENSION(DIM1) :: bufr1 ! Data buffer -REAL, DIMENSION(DIM1) :: buf2 ! Data buffer -REAL, DIMENSION(DIM1) :: bufr2 ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: buf3 ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: bufr3 ! Data buffer -INTEGER :: errcode ! Error flag -INTEGER :: i ! general purpose integer -TYPE(C_PTR) :: f_ptr -integer(HID_T) :: mytype - -CALL test_begin(' Make/Read datasets (1D) ') - -! -! Initialize the data array. -! -DO i = 1, DIM1 - buf1(i) = i; - buf2(i) = i; - buf3(i) = i; -END DO + CALL test_begin(' Make/Read datasets (1D) ') -! -! Initialize FORTRAN predefined datatypes. -! -CALL h5open_f(errcode) + ! + ! Initialize the data array. + ! + DO i = 1, DIM1 + buf1(i) = i + buf2(i) = i + buf3(i) = i + END DO -! -! Create a new file using default properties. -! -CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) + ! + ! Initialize FORTRAN predefined datatypes. + ! + CALL h5open_f(errcode) -!------------------------------------------------------------------------- -! H5T_NATIVE_INTEGER -!------------------------------------------------------------------------- + ! + ! Create a new file using default properties. + ! + CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf1, errcode) + !------------------------------------------------------------------------- + ! H5T_NATIVE_INTEGER + !------------------------------------------------------------------------- -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr1, dims, errcode) + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf1, errcode) + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr1, dims, errcode) -! -! compare read and write buffers. -! -DO i = 1, DIM1 - IF ( buf1(i) .NE. bufr1(i) ) THEN - PRINT *, 'read buffer differs from write buffer (I)' - PRINT *, bufr1(i), ' and ', buf1(i) - STOP - ENDIF -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1 + IF ( buf1(i) .NE. bufr1(i) ) THEN + PRINT *, 'read buffer differs from write buffer (I)' + PRINT *, bufr1(i), ' and ', buf1(i) + STOP + ENDIF + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_REAL -!------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! H5T_NATIVE_REAL + !------------------------------------------------------------------------- -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_REAL, buf2, errcode) + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_REAL, buf2, errcode) -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_REAL, bufr2, dims, errcode) + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_REAL, bufr2, dims, errcode) -! -! compare read and write buffers. -! -DO i = 1, DIM1 - IF ( buf2(i) .NE. bufr2(i) ) THEN - PRINT *, 'read buffer differs from write buffer (R)' - PRINT *, bufr2(i), ' and ', buf2(i) - STOP - ENDIF -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1 + IF ( buf2(i) .NE. bufr2(i) ) THEN + PRINT *, 'read buffer differs from write buffer (R)' + PRINT *, bufr2(i), ' and ', buf2(i) + STOP + ENDIF + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_DOUBLE -!------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! H5T_NATIVE_DOUBLE + !------------------------------------------------------------------------- -! -! write dataset. -! -f_ptr = C_LOC(buf3(1)) -mytype = h5kind_to_type(KIND(buf3(1)), H5_REAL_KIND) -CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, & - mytype, f_ptr, errcode) -!CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_DOUBLE, buf3, errcode) -! h5kind_to_type(KIND(buf3(1)), H5_REAL_KIND) -! -! read dataset. -! -f_ptr = C_LOC(bufr3(1)) -CALL h5ltread_dataset_f(file_id, dsetname3, & - h5kind_to_type(KIND(bufr3(1)), H5_REAL_KIND), f_ptr, errcode) -!CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_DOUBLE, bufr3, dims, errcode) + ! + ! write dataset. + ! + f_ptr = C_LOC(buf3(1)) + mytype = h5kind_to_type(KIND(buf3(1)), H5_REAL_KIND) + CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, & + mytype, f_ptr, errcode) + !CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_DOUBLE, buf3, errcode) + ! h5kind_to_type(KIND(buf3(1)), H5_REAL_KIND) + ! + ! read dataset. + ! + f_ptr = C_LOC(bufr3(1)) + CALL h5ltread_dataset_f(file_id, dsetname3, & + h5kind_to_type(KIND(bufr3(1)), H5_REAL_KIND), f_ptr, errcode) + !CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_DOUBLE, bufr3, dims, errcode) -! -! compare read and write buffers. -! -DO i = 1, DIM1 - IF ( buf3(i) .NE. bufr3(i) ) THEN - PRINT *, 'read buffer differs from write buffer (D)' - PRINT *, bufr3(i), ' and ', buf3(i) - STOP - ENDIF -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1 + IF ( buf3(i) .NE. bufr3(i) ) THEN + PRINT *, 'read buffer differs from write buffer (D)' + PRINT *, bufr3(i), ' and ', buf3(i) + STOP + ENDIF + END DO -! -! Close the file. -! -CALL h5fclose_f(file_id, errcode) + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, errcode) -! -! Close FORTRAN predefined datatypes. -! -CALL h5close_f(errcode) + ! + ! Close FORTRAN predefined datatypes. + ! + CALL h5close_f(errcode) -CALL passed() -! -! end function. -! + CALL passed() + ! + ! end function. + ! END SUBROUTINE test_dataset1D !------------------------------------------------------------------------- @@ -189,194 +188,193 @@ END SUBROUTINE test_dataset1D SUBROUTINE test_dataset2D() -USE, INTRINSIC :: ISO_C_BINDING -USE H5LT ! module of H5LT -USE HDF5 ! module of HDF5 library - -IMPLICIT NONE - - -INTEGER(HSIZE_T), PARAMETER :: DIM1 = 4; ! columns -INTEGER(HSIZE_T), PARAMETER :: DIM2 = 6; ! rows -CHARACTER(len=9), PARAMETER :: filename = "dsetf2.h5"! File name -CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name -INTEGER(HID_T) :: file_id ! File identifier -INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions -INTEGER :: rank = 2 ! Dataset rank -INTEGER, DIMENSION(DIM1*DIM2) :: buf ! Data buffer -INTEGER, DIMENSION(DIM1*DIM2) :: bufr ! Data buffer -INTEGER, DIMENSION(DIM1,DIM2) :: buf2 ! Data buffer -INTEGER, DIMENSION(DIM1,DIM2) :: buf2r ! Data buffer -REAL, DIMENSION(DIM1,DIM2), TARGET :: buf3 ! Data buffer -REAL, DIMENSION(DIM1,DIM2), TARGET :: buf3r ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1,DIM2), TARGET :: buf4 ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1,DIM2), TARGET :: buf4r ! Data buffer -INTEGER :: errcode ! Error flag -INTEGER(HSIZE_T) :: i, j, n ! general purpose integers -TYPE(C_PTR) :: f_ptr - -CALL test_begin(' Make/Read datasets (2D) ') + USE, INTRINSIC :: ISO_C_BINDING + USE H5LT ! module of H5LT + USE HDF5 ! module of HDF5 library + IMPLICIT NONE -! -! Initialize the data arrays. -! -n=1 -DO i = 1, DIM1*DIM2 - buf(i) = INT(n) - n = n + 1 -END DO -DO i = 1, dims(1) - DO j = 1, dims(2) - buf2(i,j) = INT((i-1)*dims(2) + j) - buf3(i,j) = INT((i-1)*dims(2) + j) - buf4(i,j) = INT((i-1)*dims(2) + j) - END DO -END DO + INTEGER(HSIZE_T), PARAMETER :: DIM1 = 4 ! columns + INTEGER(HSIZE_T), PARAMETER :: DIM2 = 6 ! rows + CHARACTER(len=9), PARAMETER :: filename = "dsetf2.h5"! File name + CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/4,6/) ! Dataset dimensions + INTEGER :: rank = 2 ! Dataset rank + INTEGER, DIMENSION(DIM1*DIM2) :: buf ! Data buffer + INTEGER, DIMENSION(DIM1*DIM2) :: bufr ! Data buffer + INTEGER, DIMENSION(DIM1,DIM2) :: buf2 ! Data buffer + INTEGER, DIMENSION(DIM1,DIM2) :: buf2r ! Data buffer + REAL, DIMENSION(DIM1,DIM2), TARGET :: buf3 ! Data buffer + REAL, DIMENSION(DIM1,DIM2), TARGET :: buf3r ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1,DIM2), TARGET :: buf4 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1,DIM2), TARGET :: buf4r ! Data buffer + INTEGER :: errcode ! Error flag + INTEGER(HSIZE_T) :: i, j, n ! general purpose integers + TYPE(C_PTR) :: f_ptr + CALL test_begin(' Make/Read datasets (2D) ') -! -! Initialize FORTRAN predefined datatypes. -! -CALL h5open_f(errcode) -! -! Create a new file using default properties. -! -CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) + ! + ! Initialize the data arrays. + ! + n=1 + DO i = 1, DIM1*DIM2 + buf(i) = INT(n) + n = n + 1 + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_INT 1D buffer -!------------------------------------------------------------------------- + DO i = 1, dims(1) + DO j = 1, dims(2) + buf2(i,j) = INT((i-1)*dims(2) + j) + buf3(i,j) = INT((i-1)*dims(2) + j) + buf4(i,j) = INT((i-1)*dims(2) + j) + END DO + END DO -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf, errcode) + ! + ! Initialize FORTRAN predefined datatypes. + ! + CALL h5open_f(errcode) -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr, dims, errcode) + ! + ! Create a new file using default properties. + ! + CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) -! -! compare read and write buffers. -! -DO i = 1, DIM1*DIM2 - IF ( buf(i) .NE. bufr(i) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, bufr(i), ' and ', buf(i) - STOP - ENDIF -END DO + !------------------------------------------------------------------------- + ! H5T_NATIVE_INT 1D buffer + !------------------------------------------------------------------------- -!------------------------------------------------------------------------- -! H5T_NATIVE_INT 2D buffer -!------------------------------------------------------------------------- + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf, errcode) -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_INTEGER, buf2, errcode) + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr, dims, errcode) -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_INTEGER, buf2r, dims, errcode) + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1*DIM2 + IF ( buf(i) .NE. bufr(i) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, bufr(i), ' and ', buf(i) + STOP + ENDIF + END DO -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - IF ( buf2(i,j) .NE. buf2r(i,j) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf2r(i,j), ' and ', buf2(i,j) - STOP - ENDIF - END DO -END DO + !------------------------------------------------------------------------- + ! H5T_NATIVE_INT 2D buffer + !------------------------------------------------------------------------- -!------------------------------------------------------------------------- -! H5T_NATIVE_REAL -!------------------------------------------------------------------------- + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_INTEGER, buf2, errcode) -! -! write dataset. -! -f_ptr = C_LOC(buf3(1,1)) -CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, f_ptr, errcode) -!CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, buf3, errcode) + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_INTEGER, buf2r, dims, errcode) -! -! read dataset. -! -f_ptr = C_LOC(buf3r(1,1)) -CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, f_ptr, errcode) -!CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, buf3r, dims, errcode) + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + IF ( buf2(i,j) .NE. buf2r(i,j) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf2r(i,j), ' and ', buf2(i,j) + STOP + ENDIF + END DO + END DO -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - IF ( buf3(i,j) .NE. buf3r(i,j) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf3r(i,j), ' and ', buf3(i,j) - STOP - ENDIF - END DO -END DO + !------------------------------------------------------------------------- + ! H5T_NATIVE_REAL + !------------------------------------------------------------------------- -!------------------------------------------------------------------------- -! H5T_NATIVE_DOUBLE -!------------------------------------------------------------------------- + ! + ! write dataset. + ! + f_ptr = C_LOC(buf3(1,1)) + CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, f_ptr, errcode) + !CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, buf3, errcode) -! -! write dataset. -! -f_ptr = C_LOC(buf4(1,1)) -CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, f_ptr, errcode) -!CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, buf4, errcode) + ! + ! read dataset. + ! + f_ptr = C_LOC(buf3r(1,1)) + CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, f_ptr, errcode) + !CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, buf3r, dims, errcode) -! -! read dataset. -f_ptr = C_LOC(buf4r(1,1)) -CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, f_ptr, errcode) + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + IF ( buf3(i,j) .NE. buf3r(i,j) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf3r(i,j), ' and ', buf3(i,j) + STOP + ENDIF + END DO + END DO -!CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, buf4r, dims, errcode) + !------------------------------------------------------------------------- + ! H5T_NATIVE_DOUBLE + !------------------------------------------------------------------------- -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - IF ( buf4(i,j) .NE. buf4r(i,j) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf4r(i,j), ' and ', buf4(i,j) - STOP - ENDIF - END DO -END DO + ! + ! write dataset. + ! + f_ptr = C_LOC(buf4(1,1)) + CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, f_ptr, errcode) + !CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, buf4, errcode) -! -! Close the file. -! -CALL h5fclose_f(file_id, errcode) + ! + ! read dataset. + f_ptr = C_LOC(buf4r(1,1)) + CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, f_ptr, errcode) -! -! Close FORTRAN predefined datatypes. -! -CALL h5close_f(errcode) + !CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, buf4r, dims, errcode) -CALL passed() -! -! end function. -! + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + IF ( buf4(i,j) .NE. buf4r(i,j) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf4r(i,j), ' and ', buf4(i,j) + STOP + ENDIF + END DO + END DO + + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, errcode) + + ! + ! Close FORTRAN predefined datatypes. + ! + CALL h5close_f(errcode) + + CALL passed() + ! + ! end function. + ! END SUBROUTINE test_dataset2D @@ -386,215 +384,313 @@ END SUBROUTINE test_dataset2D SUBROUTINE test_dataset3D() -USE, INTRINSIC :: ISO_C_BINDING -USE H5LT ! module of H5LT -USE HDF5 ! module of HDF5 library - -IMPLICIT NONE - -INTEGER, PARAMETER :: DIM1 = 6 ! columns -INTEGER, PARAMETER :: DIM2 = 4 ! rows -INTEGER, PARAMETER :: DIM3 = 2 ! layers -CHARACTER(len=9), PARAMETER :: filename = "dsetf3.h5" ! File name -CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name -CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name -INTEGER(HID_T) :: file_id ! File identifier -INTEGER(HSIZE_T), DIMENSION(3) :: dims = (/DIM1,DIM2,DIM3/) ! Dataset dimensions -INTEGER(HSIZE_T), DIMENSION(3) :: dimsr ! Dataset dimensions -INTEGER, DIMENSION(DIM1*DIM2*DIM3) :: buf ! Data buffer -INTEGER, DIMENSION(DIM1*DIM2*DIM3) :: bufr ! Data buffer -INTEGER, DIMENSION(DIM1,DIM2,DIM3) :: buf2 ! Data buffer -INTEGER, DIMENSION(DIM1,DIM2,DIM3) :: buf2r ! Data buffer -REAL, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf3 ! Data buffer -REAL, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf3r ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf4 ! Data buffer -DOUBLE PRECISION, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf4r ! Data buffer -INTEGER :: rank = 3 ! Dataset rank -INTEGER :: errcode ! Error flag -INTEGER(HSIZE_T) :: i, j, k, n ! general purpose integers -INTEGER :: type_class -INTEGER(SIZE_T) :: type_size -TYPE(C_PTR) :: f_ptr -CALL test_begin(' Make/Read datasets (3D) ') + USE, INTRINSIC :: ISO_C_BINDING + USE H5LT ! module of H5LT + USE HDF5 ! module of HDF5 library + IMPLICIT NONE -! -! Initialize the data array. -! -n=1 -DO i = 1, DIM1*DIM2*DIM3 - buf(i) = INT(n) - n = n + 1 -END DO - -n = 1 -DO i = 1, dims(1) - DO j = 1, dims(2) - DO k = 1, dims(3) - buf2(i,j,k) = INT(n) - buf3(i,j,k) = INT(n) - buf4(i,j,k) = INT(n) - n = n + 1 - END DO - END DO -END DO + INTEGER, PARAMETER :: DIM1 = 6 ! columns + INTEGER, PARAMETER :: DIM2 = 4 ! rows + INTEGER, PARAMETER :: DIM3 = 2 ! layers + CHARACTER(len=9), PARAMETER :: filename = "dsetf3.h5" ! File name + CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name + INTEGER(HID_T) :: file_id ! File identifier + INTEGER(HSIZE_T), DIMENSION(3) :: dims = (/DIM1,DIM2,DIM3/) ! Dataset dimensions + INTEGER(HSIZE_T), DIMENSION(3) :: dimsr ! Dataset dimensions + INTEGER, DIMENSION(DIM1*DIM2*DIM3) :: buf ! Data buffer + INTEGER, DIMENSION(DIM1*DIM2*DIM3) :: bufr ! Data buffer + INTEGER, DIMENSION(DIM1,DIM2,DIM3) :: buf2 ! Data buffer + INTEGER, DIMENSION(DIM1,DIM2,DIM3) :: buf2r ! Data buffer + REAL, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf3 ! Data buffer + REAL, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf3r ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf4 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1,DIM2,DIM3), TARGET :: buf4r ! Data buffer + INTEGER :: rank = 3 ! Dataset rank + INTEGER :: errcode ! Error flag + INTEGER(HSIZE_T) :: i, j, k, n ! general purpose integers + INTEGER :: type_class + INTEGER(SIZE_T) :: type_size + TYPE(C_PTR) :: f_ptr +#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0 + INTEGER, PARAMETER :: int_kind_32 = SELECTED_INT_KIND(36) !should map to INTEGER*16 on most modern processors + INTEGER(int_kind_32), DIMENSION(DIM1,DIM2,DIM3), TARGET :: dset_data_i32, data_out_i32 + INTEGER(HID_T) :: dset_id32 ! Dataset identifier + CHARACTER(LEN=7), PARAMETER :: dsetname16a = "dset16a" ! Dataset name + CHARACTER(LEN=7), PARAMETER :: dsetname16b = "dset16b" ! Dataset name + CHARACTER(LEN=7), PARAMETER :: dsetname16c = "dset16c" ! Dataset name + INTEGER(HID_T) :: type_id +#endif -! -! Initialize FORTRAN predefined datatypes. -! -CALL h5open_f(errcode) + CALL test_begin(' Make/Read datasets (3D) ') + + + ! + ! Initialize the data array. + ! + n=1 + DO i = 1, DIM1*DIM2*DIM3 + buf(i) = INT(n) + n = n + 1 + END DO + + n = 1 + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + buf2(i,j,k) = INT(n) + buf3(i,j,k) = INT(n) + buf4(i,j,k) = INT(n) +#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0 + dset_data_i32(i,j,k) = HUGE(1_int_kind_32)-INT(n,int_kind_32) +#endif + n = n + 1 + END DO + END DO + END DO + + ! + ! Initialize FORTRAN predefined datatypes. + ! + CALL h5open_f(errcode) + + ! + ! Create a new file using default properties. + ! + CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) + + !------------------------------------------------------------------------- + ! H5T_NATIVE_INT 1D buffer + !------------------------------------------------------------------------- + + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf, errcode) + + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr, dims, errcode) + + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1*DIM2*DIM3 + IF ( buf(i) .NE. bufr(i) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, bufr(i), ' and ', buf(i) + STOP + ENDIF + END DO + + !------------------------------------------------------------------------- + ! H5T_NATIVE_INT 3D buffer + !------------------------------------------------------------------------- + + ! + ! write dataset. + ! + CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_INTEGER, buf2, errcode) + + ! + ! read dataset. + ! + CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_INTEGER, buf2r, dims, errcode) -! -! Create a new file using default properties. -! -CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode) + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( buf2(i,j,k) .NE. buf2r(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf2r(i,j,k), ' and ', buf2(i,j,k) + STOP + ENDIF + END DO + END DO + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_INT 1D buffer -!------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! H5T_NATIVE_REAL + !------------------------------------------------------------------------- -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname1, rank, dims, H5T_NATIVE_INTEGER, buf, errcode) + ! + ! write dataset. + ! + f_ptr = C_LOC(buf3(1,1,1)) + CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, f_ptr, errcode) + !CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, buf3, errcode) -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname1, H5T_NATIVE_INTEGER, bufr, dims, errcode) + ! + ! read dataset. + ! + f_ptr = C_LOC(buf3r(1,1,1)) + CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, f_ptr, errcode) + !CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, buf3r, dims, errcode) -! -! compare read and write buffers. -! -DO i = 1, DIM1*DIM2*DIM3 - IF ( buf(i) .NE. bufr(i) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, bufr(i), ' and ', buf(i) - STOP - ENDIF -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( buf3(i,j,k) .NE. buf3r(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf3r(i,j,k), ' and ', buf3(i,j,k) + STOP + ENDIF + END DO + END DO + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_INT 3D buffer -!------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! H5T_NATIVE_DOUBLE + !------------------------------------------------------------------------- -! -! write dataset. -! -CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims, H5T_NATIVE_INTEGER, buf2, errcode) + ! + ! write dataset. + ! + f_ptr = C_LOC(buf4(1,1,1)) + CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, f_ptr, errcode) -! -! read dataset. -! -CALL h5ltread_dataset_f(file_id, dsetname2, H5T_NATIVE_INTEGER, buf2r, dims, errcode) + ! + ! read dataset. + ! + f_ptr = C_LOC(buf4r(1,1,1)) + CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, f_ptr, errcode) -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - DO k = 1, dims(3) - IF ( buf2(i,j,k) .NE. buf2r(i,j,k) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf2r(i,j,k), ' and ', buf2(i,j,k) - STOP - ENDIF - END DO - END DO -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( buf4(i,j,k) .NE. buf4r(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, buf4r(i,j,k), ' and ', buf4(i,j,k) + STOP + ENDIF + END DO + END DO + END DO -!------------------------------------------------------------------------- -! H5T_NATIVE_REAL -!------------------------------------------------------------------------- + CALL h5ltget_dataset_info_f(file_id,dsetname4,dimsr,type_class,type_size,errcode ) -! -! write dataset. -! -f_ptr = C_LOC(buf3(1,1,1)) -CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, f_ptr, errcode) -!CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims, H5T_NATIVE_REAL, buf3, errcode) + ! + ! compare dimensions + ! + DO i = 1, rank + IF ( dimsr(i) .NE. dims(i) ) THEN + PRINT *, 'dimensions differ ' + STOP + ENDIF + END DO -! -! read dataset. -! -f_ptr = C_LOC(buf3r(1,1,1)) -CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, f_ptr, errcode) -!CALL h5ltread_dataset_f(file_id, dsetname3, H5T_NATIVE_REAL, buf3r, dims, errcode) + !------------------------------------------------------------------------- + ! CHECKING NON-NATIVE INTEGER TYPES + !------------------------------------------------------------------------- -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - DO k = 1, dims(3) - IF ( buf3(i,j,k) .NE. buf3r(i,j,k) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf3r(i,j,k), ' and ', buf3(i,j,k) - STOP - ENDIF - END DO - END DO -END DO +#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0 + ! (A) CHECKING INTEGER*16 + ! + ! (i.a) write dataset using F2003 interface + ! + type_id = H5kind_to_type(KIND(dset_data_i32(1,1,1)), H5_INTEGER_KIND) + f_ptr = C_LOC(dset_data_i32(1,1,1)) + CALL h5ltmake_dataset_f(file_id, dsetname16a, rank, dims, type_id, f_ptr, errcode) + ! + ! (i.b) read dataset using F2003 interface + ! + f_ptr = C_LOC(data_out_i32(1,1,1)) + CALL h5ltread_dataset_f(file_id, dsetname16a, type_id, f_ptr, errcode) -!------------------------------------------------------------------------- -! H5T_NATIVE_DOUBLE -!------------------------------------------------------------------------- + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( dset_data_i32(i,j,k) .NE. data_out_i32(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, dset_data_i32(i,j,k), ' and ', data_out_i32(i,j,k) + STOP + ENDIF + END DO + END DO + ENDDO -! -! write dataset. -! -f_ptr = C_LOC(buf4(1,1,1)) -CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims, H5T_NATIVE_DOUBLE, f_ptr, errcode) + ! + ! (ii.a) write dataset using F90 interface + ! + type_id = H5kind_to_type(KIND(dset_data_i32(1,1,1)), H5_INTEGER_KIND) + CALL h5ltmake_dataset_f(file_id, dsetname16b, rank, dims, type_id, dset_data_i32, errcode) + ! + ! (ii.b) read dataset using F90 interface + ! + CALL h5ltread_dataset_f(file_id, dsetname16b, type_id, data_out_i32, dims, errcode) -! -! read dataset. -! -f_ptr = C_LOC(buf4r(1,1,1)) -CALL h5ltread_dataset_f(file_id, dsetname4, H5T_NATIVE_DOUBLE, f_ptr, errcode) + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( dset_data_i32(i,j,k) .NE. data_out_i32(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, dset_data_i32(i,j,k), ' and ', data_out_i32(i,j,k) + STOP + ENDIF + END DO + END DO + ENDDO -! -! compare read and write buffers. -! -DO i = 1, dims(1) - DO j = 1, dims(2) - DO k = 1, dims(3) - IF ( buf4(i,j,k) .NE. buf4r(i,j,k) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, buf4r(i,j,k), ' and ', buf4(i,j,k) - STOP - ENDIF - END DO - END DO -END DO + ! + ! (iii.a) write dataset using F90 H5LTmake_dataset_int_f interface + ! + CALL h5ltmake_dataset_int_f(file_id, dsetname16c, rank, dims, dset_data_i32, errcode) -CALL h5ltget_dataset_info_f(file_id,dsetname4,dimsr,type_class,type_size,errcode ) + ! + ! (iii.b) read dataset using F90 H5LTmake_dataset_int_f interface + ! + CALL h5ltread_dataset_int_f(file_id, dsetname16c, data_out_i32, dims, errcode) -! -! compare dimensions -! -DO i = 1, rank - IF ( dimsr(i) .NE. dims(i) ) THEN - PRINT *, 'dimensions differ ' - STOP - ENDIF -END DO + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + IF ( dset_data_i32(i,j,k) .NE. data_out_i32(i,j,k) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, dset_data_i32(i,j,k), ' and ', data_out_i32(i,j,k) + STOP + ENDIF + END DO + END DO + ENDDO -! -! Close the file. -! -CALL h5fclose_f(file_id, errcode) +#endif -! -! Close FORTRAN predefined datatypes. -! -CALL h5close_f(errcode) + ! + ! Close the file. + ! + CALL h5fclose_f(file_id, errcode) -CALL passed() -! -! end function. -! + ! + ! Close FORTRAN predefined datatypes. + ! + CALL h5close_f(errcode) + + CALL passed() + ! + ! end function. + ! END SUBROUTINE test_dataset3D !------------------------------------------------------------------------- @@ -623,6 +719,7 @@ SUBROUTINE test_datasetND(rank) CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name + CHARACTER(LEN=5), PARAMETER :: dsetname5 = "dset5" ! Dataset name INTEGER(HID_T) :: file_id ! File identifier INTEGER(HSIZE_T), DIMENSION(7) :: dims INTEGER(HSIZE_T), DIMENSION(7) :: dimsr ! Dataset dimensions @@ -650,29 +747,41 @@ SUBROUTINE test_datasetND(rank) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:), TARGET :: dbufr_6 ! Data buffer DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:), TARGET :: dbuf_7 ! Data buffer DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:), TARGET :: dbufr_7 ! Data buffer - INTEGER :: errcode ! Error flag - INTEGER(HSIZE_T) :: i, j, k, l, m, n, o, nn ! general purpose integers + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:), TARGET :: cbuf_4 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:), TARGET :: cbufr_4 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:), TARGET :: cbuf_5 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:), TARGET :: cbufr_5 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:,:), TARGET :: cbuf_6 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:,:), TARGET :: cbufr_6 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:), TARGET :: cbuf_7 ! Data buffer + CHARACTER(LEN=5), ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:), TARGET :: cbufr_7 ! Data buffer + INTEGER :: errcode ! Error flag + INTEGER(HSIZE_T) :: i, j, k, l, m, n, o, nn ! general purpose integers INTEGER :: type_class INTEGER(SIZE_T) :: type_size CHARACTER(LEN=1) :: ichr1 + CHARACTER(LEN=3) :: ichr3 TYPE(C_PTR) :: f_ptr + INTEGER(HID_T) :: type_id WRITE(ichr1,'(I1.1)') rank CALL test_begin(' Make/Read datasets ('//ichr1//'D) ') -! -! Initialize the data array. -! + ! + ! Initialize the data array. + ! IF(rank.EQ.4)THEN - + ALLOCATE(ibuf_4 (1:DIM1,1:DIM2,1:DIM3,1:DIM4)) ALLOCATE(ibufr_4(1:DIM1,1:DIM2,1:DIM3,1:DIM4)) ALLOCATE(rbuf_4 (1:DIM1,1:DIM2,1:DIM3,1:DIM4)) ALLOCATE(rbufr_4(1:DIM1,1:DIM2,1:DIM3,1:DIM4)) ALLOCATE(dbuf_4 (1:DIM1,1:DIM2,1:DIM3,1:DIM4)) ALLOCATE(dbufr_4(1:DIM1,1:DIM2,1:DIM3,1:DIM4)) + ALLOCATE(cbuf_4 (1:DIM1,1:DIM2,1:DIM3,1:DIM4)) + ALLOCATE(cbufr_4(1:DIM1,1:DIM2,1:DIM3,1:DIM4)) dims(1:7) = (/DIM1,DIM2,DIM3,DIM4,0,0,0/) - + nn = 1 DO i = 1, DIM1 DO j = 1, DIM2 @@ -681,12 +790,14 @@ SUBROUTINE test_datasetND(rank) ibuf_4(i,j,k,l) = INT(nn) rbuf_4(i,j,k,l) = INT(nn) dbuf_4(i,j,k,l) = INT(nn) + WRITE(cbuf_4(i,j,k,l),'(I5.5)') nn nn = nn + 1 END DO END DO END DO + ENDDO - + ELSE IF(rank.EQ.5)THEN ALLOCATE(ibuf_5 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) @@ -695,9 +806,11 @@ SUBROUTINE test_datasetND(rank) ALLOCATE(rbufr_5(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) ALLOCATE(dbuf_5 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) ALLOCATE(dbufr_5(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) + ALLOCATE(cbuf_5 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) + ALLOCATE(cbufr_5(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5)) dims(1:7) = (/DIM1,DIM2,DIM3,DIM4,DIM5,0,0/) - + nn = 1 DO i = 1, DIM1 DO j = 1, DIM2 @@ -707,6 +820,7 @@ SUBROUTINE test_datasetND(rank) ibuf_5(i,j,k,l,m) = INT(nn) rbuf_5(i,j,k,l,m) = INT(nn) dbuf_5(i,j,k,l,m) = INT(nn) + WRITE(cbuf_5(i,j,k,l,m),'(I5.5)') nn nn = nn + 1 END DO END DO @@ -722,9 +836,11 @@ SUBROUTINE test_datasetND(rank) ALLOCATE(rbufr_6(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6)) ALLOCATE(dbuf_6 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6)) ALLOCATE(dbufr_6(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6)) + ALLOCATE(cbuf_6 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6)) + ALLOCATE(cbufr_6(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6)) dims(1:7) = (/DIM1,DIM2,DIM3,DIM4,DIM5,DIM6,0/) - + nn = 1 DO i = 1, DIM1 DO j = 1, DIM2 @@ -735,6 +851,7 @@ SUBROUTINE test_datasetND(rank) ibuf_6(i,j,k,l,m,n) = INT(nn) rbuf_6(i,j,k,l,m,n) = INT(nn) dbuf_6(i,j,k,l,m,n) = INT(nn) + WRITE(cbuf_6(i,j,k,l,m,n),'(I5.5)') nn nn = nn + 1 END DO END DO @@ -742,18 +859,20 @@ SUBROUTINE test_datasetND(rank) ENDDO ENDDO ENDDO - + ELSE IF(rank.EQ.7)THEN - + ALLOCATE(ibuf_7 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) ALLOCATE(ibufr_7(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) ALLOCATE(rbuf_7 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) ALLOCATE(rbufr_7(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) ALLOCATE(dbuf_7 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) ALLOCATE(dbufr_7(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) + ALLOCATE(cbuf_7 (1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) + ALLOCATE(cbufr_7(1:DIM1,1:DIM2,1:DIM3,1:DIM4,1:DIM5,1:DIM6,1:DIM7)) dims(1:7) = (/DIM1,DIM2,DIM3,DIM4,DIM5,DIM6,DIM7/) - + nn = 1 DO i = 1, DIM1 DO j = 1, DIM2 @@ -765,6 +884,7 @@ SUBROUTINE test_datasetND(rank) ibuf_7(i,j,k,l,m,n,o) = INT(nn) rbuf_7(i,j,k,l,m,n,o) = INT(nn) dbuf_7(i,j,k,l,m,n,o) = INT(nn) + WRITE(cbuf_7(i,j,k,l,m,n,o),'(I5.5)') nn nn = nn + 1 END DO END DO @@ -803,7 +923,7 @@ SUBROUTINE test_datasetND(rank) ELSE IF(rank.EQ.7)THEN CALL h5ltmake_dataset_f(file_id, dsetname2, rank, dims(1:rank), H5T_NATIVE_INTEGER, ibuf_7, errcode) ENDIF - + ! ! read dataset. @@ -874,7 +994,7 @@ SUBROUTINE test_datasetND(rank) IF(rank.EQ.4)THEN f_ptr = C_LOC(rbuf_4(1,1,1,1)) CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, f_ptr, errcode) - ! CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, rbuf_4, errcode) + ! CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, rbuf_4, errcode) ELSE IF(rank.EQ.5)THEN f_ptr = C_LOC(rbuf_5(1,1,1,1,1)) CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, f_ptr, errcode) @@ -887,7 +1007,7 @@ SUBROUTINE test_datasetND(rank) CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, f_ptr, errcode) !CALL h5ltmake_dataset_f(file_id, dsetname3, rank, dims(1:rank), H5T_NATIVE_REAL, rbuf_7, errcode) ENDIF - + ! ! read dataset. @@ -972,7 +1092,6 @@ SUBROUTINE test_datasetND(rank) f_ptr = C_LOC(dbuf_7(1,1,1,1,1,1,1)) CALL h5ltmake_dataset_f(file_id, dsetname4, rank, dims(1:rank), H5T_NATIVE_DOUBLE, f_ptr, errcode) ENDIF - ! ! read dataset. @@ -1037,8 +1156,97 @@ SUBROUTINE test_datasetND(rank) ENDDO ENDDO + !------------------------------------------------------------------------- + ! H5T_NATIVE_CHARACTER ND buffer + !------------------------------------------------------------------------- + + CALL H5Tcopy_f(H5T_FORTRAN_S1, type_id, errcode) + CALL H5Tset_size_f(type_id, 5_SIZE_T, errcode) + ! + ! write dataset. + ! + IF(rank.EQ.4)THEN + f_ptr = C_LOC(cbuf_4(1,1,1,1)(1:1)) + CALL h5ltmake_dataset_f(file_id, dsetname5, rank, dims(1:rank), type_id, f_ptr, errcode) + ELSE IF(rank.EQ.5)THEN + f_ptr = C_LOC(cbuf_5(1,1,1,1,1)(1:1)) + CALL h5ltmake_dataset_f(file_id, dsetname5, rank, dims(1:rank), type_id, f_ptr, errcode) + ELSE IF(rank.EQ.6)THEN + f_ptr = C_LOC(cbuf_6(1,1,1,1,1,1)(1:1)) + CALL h5ltmake_dataset_f(file_id, dsetname5, rank, dims(1:rank), type_id, f_ptr, errcode) + ELSE IF(rank.EQ.7)THEN + f_ptr = C_LOC(cbuf_7(1,1,1,1,1,1,1)(1:1)) + CALL h5ltmake_dataset_f(file_id, dsetname5, rank, dims(1:rank), type_id, f_ptr, errcode) + ENDIF + + ! + ! read dataset. + ! + IF(rank.EQ.4)THEN + f_ptr = C_LOC(cbufr_4(1,1,1,1)(1:1)) + CALL h5ltread_dataset_f(file_id, dsetname5, type_id, f_ptr, errcode) + ELSE IF(rank.EQ.5)THEN + f_ptr = C_LOC(cbufr_5(1,1,1,1,1)(1:1)) + CALL h5ltread_dataset_f(file_id, dsetname5, type_id, f_ptr, errcode) + ELSE IF(rank.EQ.6)THEN + f_ptr = C_LOC(cbufr_6(1,1,1,1,1,1)(1:1)) + CALL h5ltread_dataset_f(file_id, dsetname5, type_id, f_ptr, errcode) + ELSE IF(rank.EQ.7)THEN + f_ptr = C_LOC(cbufr_7(1,1,1,1,1,1,1)(1:1)) + CALL h5ltread_dataset_f(file_id, dsetname5, type_id, f_ptr, errcode) + ENDIF + + + ! + ! compare read and write buffers. + ! + DO i = 1, dims(1) + DO j = 1, dims(2) + DO k = 1, dims(3) + DO l = 1, dims(4) + IF(rank.EQ.4)THEN + IF ( cbuf_4(i,j,k,l) .NE. cbufr_4(i,j,k,l) ) THEN + PRINT *, 'read buffer differs from write buffer (character)' + PRINT *, cbuf_4(i,j,k,l), ' and ', cbufr_4(i,j,k,l) + STOP + ENDIF + ENDIF + DO m = 1, dims(5) + IF(rank.EQ.5)THEN + IF ( cbuf_5(i,j,k,l,m) .NE. cbufr_5(i,j,k,l,m) ) THEN + PRINT *, 'read buffer differs from write buffer (character)' + PRINT *, cbuf_5(i,j,k,l,m), ' and ', cbufr_5(i,j,k,l,m) + STOP + ENDIF + ENDIF + DO n = 1, dims(6) + IF(rank.EQ.6)THEN + IF ( cbuf_6(i,j,k,l,m,n) .NE. cbufr_6(i,j,k,l,m,n) ) THEN + PRINT *, 'read buffer differs from write buffer (character)' + PRINT *, cbuf_6(i,j,k,l,m,n), ' and ', cbufr_6(i,j,k,l,m,n) + STOP + ENDIF + ENDIF + DO o = 1, dims(7) + IF(rank.EQ.7)THEN + IF ( cbuf_7(i,j,k,l,m,n,o) .NE. cbufr_7(i,j,k,l,m,n,o) ) THEN + PRINT *, 'read buffer differs from write buffer (character)' + PRINT *, cbuf_7(i,j,k,l,m,n,o), ' and ', cbufr_7(i,j,k,l,m,n,o) + STOP + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + CALL h5ltget_dataset_info_f(file_id,dsetname4,dimsr,type_class,type_size,errcode ) + CALL h5tclose_f(type_id,errcode) + ! ! compare dimensions ! @@ -1062,13 +1270,13 @@ SUBROUTINE test_datasetND(rank) ! DEALLOCATE RESOURCES IF(rank.EQ.4)THEN - DEALLOCATE(ibuf_4, ibufr_4, rbuf_4, rbufr_4, dbuf_4, dbufr_4) + DEALLOCATE(ibuf_4, ibufr_4, rbuf_4, rbufr_4, dbuf_4, dbufr_4, cbuf_4, cbufr_4) ELSE IF(rank.EQ.5)THEN - DEALLOCATE(ibuf_5, ibufr_5, rbuf_5, rbufr_5, dbuf_5, dbufr_5) + DEALLOCATE(ibuf_5, ibufr_5, rbuf_5, rbufr_5, dbuf_5, dbufr_5, cbuf_5, cbufr_5) ELSE IF(rank.EQ.6)THEN - DEALLOCATE(ibuf_6, ibufr_6, rbuf_6, rbufr_6, dbuf_6, dbufr_6) + DEALLOCATE(ibuf_6, ibufr_6, rbuf_6, rbufr_6, dbuf_6, dbufr_6, cbuf_6, cbufr_6) ELSE IF(rank.EQ.7)THEN - DEALLOCATE(ibuf_7, ibufr_7, rbuf_7, rbufr_7, dbuf_7, dbufr_7) + DEALLOCATE(ibuf_7, ibufr_7, rbuf_7, rbufr_7, dbuf_7, dbufr_7, cbuf_7, cbufr_7) ENDIF CALL passed() @@ -1078,7 +1286,6 @@ SUBROUTINE test_datasetND(rank) END SUBROUTINE test_datasetND - !------------------------------------------------------------------------- ! test_datasets !------------------------------------------------------------------------- @@ -1094,7 +1301,7 @@ SUBROUTINE test_datasets() CHARACTER(len=9), PARAMETER :: filename = "dsetf4.h5"! File name INTEGER(HID_T) :: file_id ! File identifier INTEGER :: errcode ! Error flag - INTEGER, PARAMETER :: DIM1 = 10 ! Dimension of array + INTEGER, PARAMETER :: DIM1 = 10 ! Dimension of array CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name CHARACTER(LEN=5), PARAMETER :: dsetname3 = "dset3" ! Dataset name @@ -1108,10 +1315,10 @@ SUBROUTINE test_datasets() CHARACTER(LEN=8) :: buf1r ! Data buffer INTEGER, DIMENSION(DIM1) :: buf2 ! Data buffer INTEGER, DIMENSION(DIM1) :: bufr2 ! Data buffer - REAL, DIMENSION(DIM1), TARGET :: buf3 ! Data buffer - REAL, DIMENSION(DIM1) , TARGET :: bufr3 ! Data buffer - DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: buf4 ! Data buffer - DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: bufr4 ! Data buffer + REAL, DIMENSION(DIM1), TARGET :: buf3 ! Data buffer + REAL, DIMENSION(DIM1) , TARGET :: bufr3 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: buf4 ! Data buffer + DOUBLE PRECISION, DIMENSION(DIM1), TARGET :: bufr4 ! Data buffer INTEGER :: i, n ! general purpose integer INTEGER :: has ! general purpose integer INTEGER :: type_class @@ -1289,7 +1496,7 @@ SUBROUTINE test_datasets() IF(errcode.LT.0.OR..NOT.path_valid)THEN PRINT *, 'error in h5ltpath_valid_f' STOP - ENDIF + ENDIF ! Should fail, dataset does not exist CALL h5ltpath_valid_f(file_id, "/"//dsetname2//"junk", .TRUE., path_valid, errcode) @@ -1306,14 +1513,14 @@ SUBROUTINE test_datasets() ! Create a dangling soft link CALL h5lcreate_soft_f("/G2", file_id, "/G3", errcode) - + ! Should pass, does not check for dangled link CALL h5ltpath_valid_f(file_id, "/G3", .FALSE., path_valid, errcode) IF(.NOT.path_valid)THEN PRINT *, 'error in h5ltpath_valid_f' STOP ENDIF - + ! Should fail, dangled link CALL h5ltpath_valid_f(file_id, "/G2", .TRUE., path_valid, errcode) IF(path_valid)THEN @@ -1336,7 +1543,6 @@ SUBROUTINE test_datasets() STOP ENDIF - !------------------------------------------------------------------------- ! test h5ltfind_dataset_f function !------------------------------------------------------------------------- @@ -1352,7 +1558,6 @@ SUBROUTINE test_datasets() ! test h5ltget_dataset_info_f function !------------------------------------------------------------------------- - CALL h5ltget_dataset_info_f(file_id,dsetname4,dimsr,type_class,type_size,errcode ) ! @@ -1402,7 +1607,7 @@ SUBROUTINE test_attributes() CHARACTER(len=9), PARAMETER :: filename = "dsetf5.h5"! File name CHARACTER(len=9), PARAMETER :: filename1 ="tattr.h5" ! C written attribute file INTEGER(HID_T) :: file_id ! File identifier -! INTEGER(HID_T) :: file_id1 + ! INTEGER(HID_T) :: file_id1 INTEGER, PARAMETER :: DIM1 = 10 ! Dimension of array CHARACTER(LEN=5), PARAMETER :: attrname1 = "attr1" ! Attribute name CHARACTER(LEN=5), PARAMETER :: attrname2 = "attr2" ! Attribute name @@ -1413,8 +1618,8 @@ SUBROUTINE test_attributes() CHARACTER(LEN=16), PARAMETER :: buf_c = "string attribute" CHARACTER(LEN=8) :: bufr1 ! Data buffer CHARACTER(LEN=10) :: bufr1_lg ! Data buffer -! CHARACTER(LEN=16) :: bufr_c ! Data buffer -! CHARACTER(LEN=18) :: bufr_c_lg ! Data buffer + ! CHARACTER(LEN=16) :: bufr_c ! Data buffer + ! CHARACTER(LEN=18) :: bufr_c_lg ! Data buffer INTEGER, DIMENSION(DIM1) :: buf2 ! Data buffer INTEGER, DIMENSION(DIM1) :: bufr2 ! Data buffer REAL, DIMENSION(DIM1), target :: buf3 ! Data buffer @@ -1547,41 +1752,41 @@ SUBROUTINE test_attributes() IF(SizeOf_buf_type.LT.16)THEN ! MSB can't handle 16 byte reals - CALL test_begin(' Set/Get attributes double ') + CALL test_begin(' Set/Get attributes double ') - ! - ! write attribute. - ! - f_ptr = C_LOC(buf4(1)) - CALL h5ltset_attribute_f(file_id,dsetname1,attrname4,f_ptr,"real", SizeOf_buf_type, size, errcode) + ! + ! write attribute. + ! + f_ptr = C_LOC(buf4(1)) + CALL h5ltset_attribute_f(file_id,dsetname1,attrname4,f_ptr,"real", SizeOf_buf_type, size, errcode) -! CALL h5ltset_attribute_double_f(file_id,dsetname1,attrname4,buf4, size, errcode) + ! CALL h5ltset_attribute_double_f(file_id,dsetname1,attrname4,buf4, size, errcode) - ! - ! read attribute. - ! + ! + ! read attribute. + ! #ifdef H5_FORTRAN_HAVE_STORAGE_SIZE - SizeOf_buf_type = STORAGE_SIZE(bufr4(1), c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t) + SizeOf_buf_type = STORAGE_SIZE(bufr4(1), c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t) #else - SizeOf_buf_type = SIZEOF(bufr4(1)) + SizeOf_buf_type = SIZEOF(bufr4(1)) #endif - f_ptr = C_LOC(bufr4(1)) - CALL h5ltget_attribute_f(file_id,dsetname1,attrname4,f_ptr,"REAL",SizeOf_buf_type,errcode) - - ! - ! compare read and write buffers. - ! - DO i = 1, DIM1 - IF ( buf4(i) .NE. bufr4(i) ) THEN - PRINT *, 'read buffer differs from write buffer' - PRINT *, bufr4(i), ' and ', buf4(i) - STOP - ENDIF - END DO + f_ptr = C_LOC(bufr4(1)) + CALL h5ltget_attribute_f(file_id,dsetname1,attrname4,f_ptr,"REAL",SizeOf_buf_type,errcode) - CALL passed() + ! + ! compare read and write buffers. + ! + DO i = 1, DIM1 + IF ( buf4(i) .NE. bufr4(i) ) THEN + PRINT *, 'read buffer differs from write buffer' + PRINT *, bufr4(i), ' and ', buf4(i) + STOP + ENDIF + END DO + + CALL passed() ENDIF diff --git a/hl/src/Makefile.in b/hl/src/Makefile.in index 9f97734..f4c9b48 100644 --- a/hl/src/Makefile.in +++ b/hl/src/Makefile.in @@ -460,6 +460,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/test/Makefile.in b/hl/test/Makefile.in index 61d2e05..78ef042 100644 --- a/hl/test/Makefile.in +++ b/hl/test/Makefile.in @@ -510,6 +510,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/tools/Makefile.in b/hl/tools/Makefile.in index 813b766..64e0d23 100644 --- a/hl/tools/Makefile.in +++ b/hl/tools/Makefile.in @@ -459,6 +459,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/tools/gif2h5/Makefile.in b/hl/tools/gif2h5/Makefile.in index 5dda20f..b41fcb3 100644 --- a/hl/tools/gif2h5/Makefile.in +++ b/hl/tools/gif2h5/Makefile.in @@ -473,6 +473,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/hl/tools/h5watch/Makefile.in b/hl/tools/h5watch/Makefile.in index 0e229c9..489f171 100644 --- a/hl/tools/h5watch/Makefile.in +++ b/hl/tools/h5watch/Makefile.in @@ -476,6 +476,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/src/H5config.h.in b/src/H5config.h.in index cca6e34..d6f5258 100644 --- a/src/H5config.h.in +++ b/src/H5config.h.in @@ -48,6 +48,9 @@ /* Determine the size of C long double */ #undef FORTRAN_SIZEOF_LONG_DOUBLE +/* Define Fortran compiler ID */ +#undef Fortran_COMPILER_ID + /* Define valid Fortran INTEGER KINDs */ #undef H5CONFIG_F_IKIND diff --git a/src/Makefile.in b/src/Makefile.in index ad466fb..34fde74 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -525,6 +525,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/test/CMakeTests.cmake b/test/CMakeTests.cmake index 5fe51ed..10f4ccf 100644 --- a/test/CMakeTests.cmake +++ b/test/CMakeTests.cmake @@ -451,6 +451,7 @@ set_tests_properties (H5TEST-flush2 PROPERTIES DEPENDS H5TEST-flush1) set_tests_properties (H5TEST-fheap PROPERTIES TIMEOUT 1800) set_tests_properties (H5TEST-testmeta PROPERTIES TIMEOUT 1800) set_tests_properties (H5TEST-big PROPERTIES TIMEOUT 1800) +set_tests_properties (H5TEST-objcopy PROPERTIES TIMEOUT 2400) if (BUILD_SHARED_LIBS) # Remove any output file left over from previous test run @@ -541,6 +542,7 @@ if (BUILD_SHARED_LIBS) set_tests_properties (H5TEST-shared-fheap PROPERTIES TIMEOUT 1800) set_tests_properties (H5TEST-shared-testmeta PROPERTIES TIMEOUT 1800) set_tests_properties (H5TEST-shared-big PROPERTIES TIMEOUT 1800) + set_tests_properties (H5TEST-shared-objcopy PROPERTIES TIMEOUT 2400) endif (BUILD_SHARED_LIBS) ############################################################################## @@ -562,9 +564,10 @@ if (NOT CYGWIN) add_test (NAME H5TEST-cache COMMAND $) set_tests_properties (H5TEST-cache PROPERTIES DEPENDS H5TEST-clear-cache-objects - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/H5TEST;HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/H5TEST;HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/H5TEST ) + set_tests_properties (H5TEST-cache PROPERTIES TIMEOUT 2400) endif (NOT CYGWIN) #-- Adding test for cache_api @@ -725,9 +728,10 @@ if (BUILD_SHARED_LIBS) add_test (NAME H5TEST-shared-cache COMMAND $) set_tests_properties (H5TEST-shared-cache PROPERTIES DEPENDS H5TEST-shared-clear-cache-objects - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/H5TEST-shared;HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/H5TEST-shared;HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/H5TEST-shared ) + set_tests_properties (H5TEST-shared-cache PROPERTIES TIMEOUT 2400) endif (NOT CYGWIN) #-- Adding test for cache_api @@ -1052,7 +1056,7 @@ if (HDF5_TEST_VFD) -P "${HDF_RESOURCES_DIR}/vfdTest.cmake" ) set_tests_properties (VFD-${vfdname}-${vfdtest} PROPERTIES - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname};HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname};HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/${vfdname} ) if (BUILD_SHARED_LIBS) @@ -1068,7 +1072,7 @@ if (HDF5_TEST_VFD) -P "${HDF_RESOURCES_DIR}/vfdTest.cmake" ) set_tests_properties (VFD-${vfdname}-${vfdtest}-shared PROPERTIES - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname}-shared;HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname}-shared;HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/${vfdname}-shared ) endif (BUILD_SHARED_LIBS) @@ -1136,7 +1140,7 @@ if (HDF5_TEST_VFD) ) set_tests_properties (VFD-${vfdname}-fheap PROPERTIES TIMEOUT 1800 - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname};HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname};HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/${vfdname} ) if (BUILD_SHARED_LIBS) @@ -1153,7 +1157,7 @@ if (HDF5_TEST_VFD) ) set_tests_properties (VFD-${vfdname}-fheap-shared PROPERTIES TIMEOUT 1800 - ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname}-shared;HDF5TestExpress=2" + ENVIRONMENT "srcdir=${HDF5_TEST_BINARY_DIR}/${vfdname}-shared;HDF5TestExpress=${HDF_TEST_EXPRESS}" WORKING_DIRECTORY ${HDF5_TEST_BINARY_DIR}/${vfdname}-shared ) endif (BUILD_SHARED_LIBS) diff --git a/test/Makefile.in b/test/Makefile.in index d0270ba..112837d 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -984,6 +984,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/testpar/Makefile.in b/testpar/Makefile.in index e70d05e..223247a 100644 --- a/testpar/Makefile.in +++ b/testpar/Makefile.in @@ -492,6 +492,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/Makefile.in b/tools/Makefile.in index 6d699eb..d8678e2 100644 --- a/tools/Makefile.in +++ b/tools/Makefile.in @@ -459,6 +459,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5copy/Makefile.in b/tools/h5copy/Makefile.in index 57c0a38..3900396 100644 --- a/tools/h5copy/Makefile.in +++ b/tools/h5copy/Makefile.in @@ -467,6 +467,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5diff/Makefile.in b/tools/h5diff/Makefile.in index 638afd6..ebfb680 100644 --- a/tools/h5diff/Makefile.in +++ b/tools/h5diff/Makefile.in @@ -474,6 +474,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5dump/Makefile.in b/tools/h5dump/Makefile.in index cfb268c..208e4e0 100644 --- a/tools/h5dump/Makefile.in +++ b/tools/h5dump/Makefile.in @@ -473,6 +473,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5format_convert/Makefile.in b/tools/h5format_convert/Makefile.in index 43700b0..d46643a 100644 --- a/tools/h5format_convert/Makefile.in +++ b/tools/h5format_convert/Makefile.in @@ -472,6 +472,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5import/Makefile.in b/tools/h5import/Makefile.in index 3185d72..938f3d9 100644 --- a/tools/h5import/Makefile.in +++ b/tools/h5import/Makefile.in @@ -467,6 +467,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5jam/Makefile.in b/tools/h5jam/Makefile.in index 8e5f994..9452a9b 100644 --- a/tools/h5jam/Makefile.in +++ b/tools/h5jam/Makefile.in @@ -479,6 +479,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5ls/Makefile.in b/tools/h5ls/Makefile.in index b23d07f..73bef6c 100644 --- a/tools/h5ls/Makefile.in +++ b/tools/h5ls/Makefile.in @@ -459,6 +459,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5repack/Makefile.in b/tools/h5repack/Makefile.in index 6868523..02be99d 100644 --- a/tools/h5repack/Makefile.in +++ b/tools/h5repack/Makefile.in @@ -491,6 +491,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/h5stat/Makefile.in b/tools/h5stat/Makefile.in index a03b765..e0d095d 100644 --- a/tools/h5stat/Makefile.in +++ b/tools/h5stat/Makefile.in @@ -469,6 +469,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/lib/Makefile.in b/tools/lib/Makefile.in index ab7940e..ba26950 100644 --- a/tools/lib/Makefile.in +++ b/tools/lib/Makefile.in @@ -456,6 +456,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/misc/Makefile.in b/tools/misc/Makefile.in index 707fa58..59cfde4 100644 --- a/tools/misc/Makefile.in +++ b/tools/misc/Makefile.in @@ -513,6 +513,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ diff --git a/tools/perform/Makefile.in b/tools/perform/Makefile.in index 292a65b..dbac43e 100644 --- a/tools/perform/Makefile.in +++ b/tools/perform/Makefile.in @@ -498,6 +498,7 @@ FORTRAN_C_LONG_DOUBLE_IS_UNIQUE = @FORTRAN_C_LONG_DOUBLE_IS_UNIQUE@ FORTRAN_HAVE_C_LONG_DOUBLE = @FORTRAN_HAVE_C_LONG_DOUBLE@ FORTRAN_SIZEOF_LONG_DOUBLE = @FORTRAN_SIZEOF_LONG_DOUBLE@ FSEARCH_DIRS = @FSEARCH_DIRS@ +Fortran_COMPILER_ID = @Fortran_COMPILER_ID@ GREP = @GREP@ H5CONFIG_F_IKIND = @H5CONFIG_F_IKIND@ H5CONFIG_F_NUM_IKIND = @H5CONFIG_F_NUM_IKIND@ -- cgit v0.12