diff options
Diffstat (limited to 'fortran/test')
| -rw-r--r-- | fortran/test/Makefile.am | 15 | ||||
| -rw-r--r-- | fortran/test/Makefile.in | 117 | ||||
| -rw-r--r-- | fortran/test/fflush1.f90 | 8 | ||||
| -rw-r--r-- | fortran/test/fflush2.f90 | 11 | ||||
| -rw-r--r-- | fortran/test/fortranlib_test_1_8.f90 | 447 | ||||
| -rw-r--r-- | fortran/test/tH5A.f90 | 111 | ||||
| -rw-r--r-- | fortran/test/tH5A_1_8.f90 | 3279 | ||||
| -rw-r--r-- | fortran/test/tH5F.f90 | 2 | ||||
| -rw-r--r-- | fortran/test/tH5G.f90 | 5 | ||||
| -rw-r--r-- | fortran/test/tH5G_1_8.f90 | 2043 | ||||
| -rw-r--r-- | fortran/test/tH5O.f90 | 446 | ||||
| -rw-r--r-- | fortran/test/tH5R.f90 | 768 | ||||
| -rw-r--r-- | fortran/test/tH5Sselect.f90 | 35 | ||||
| -rw-r--r-- | fortran/test/tH5T.f90 | 65 | ||||
| -rw-r--r-- | fortran/test/tH5VL.f90 | 4 | ||||
| -rw-r--r-- | fortran/test/tH5Z.f90 | 2 | ||||
| -rw-r--r-- | fortran/test/tf.f90 | 218 |
17 files changed, 6962 insertions, 614 deletions
diff --git a/fortran/test/Makefile.am b/fortran/test/Makefile.am index ed4b9fd..7d619d9 100644 --- a/fortran/test/Makefile.am +++ b/fortran/test/Makefile.am @@ -36,12 +36,10 @@ else endif # Our main targets, the tests themselves -TEST_PROG=fortranlib_test fflush1 fflush2 +TEST_PROG=fortranlib_test fflush1 fflush2 fortranlib_test_1_8 check_PROGRAMS=$(TEST_PROG) -libh5test_fortran_la_SOURCES=fortranlib_test.f90 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 tf.f90 t.c +libh5test_fortran_la_SOURCES= tf.f90 t.c # Source files are used for both the library and fortranlib_test. # Automake will complain about this without the following workaround. @@ -50,8 +48,11 @@ fortranlib_test_CFLAGS=$(AM_CFLAGS) fortranlib_test_SOURCES = fortranlib_test.f90 \ 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 tf.f90 \ - t.c + tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90 + +fortranlib_test_1_8_SOURCES = fortranlib_test_1_8.f90 \ + tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90 + fflush1_SOURCES=fflush1.f90 fflush2_SOURCES=fflush2.f90 @@ -64,7 +65,7 @@ MOSTLYCLEANFILES=*.tmp # Mark this directory as part of the Fortran API (this affects output # from tests in conclude.am) -HDF_FORTRAN=yes +FORTRAN_API=yes # fflush2 depends on files created by fflush1 fflush2.chkexe_: fflush1.chkexe_ diff --git a/fortran/test/Makefile.in b/fortran/test/Makefile.in index 5e0b92f..43f713b 100644 --- a/fortran/test/Makefile.in +++ b/fortran/test/Makefile.in @@ -1,8 +1,8 @@ -# Makefile.in generated by automake 1.10 from Makefile.am. +# Makefile.in generated by automake 1.10.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -# 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +# 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -64,12 +64,10 @@ CONFIG_HEADER = $(top_builddir)/src/H5config.h CONFIG_CLEAN_FILES = LTLIBRARIES = $(noinst_LTLIBRARIES) libh5test_fortran_la_LIBADD = -am_libh5test_fortran_la_OBJECTS = fortranlib_test.lo tH5F.lo tH5D.lo \ - tH5R.lo tH5S.lo tH5T.lo tH5VL.lo tH5Z.lo tH5Sselect.lo tH5P.lo \ - tH5A.lo tH5I.lo tH5G.lo tH5E.lo tf.lo t.lo +am_libh5test_fortran_la_OBJECTS = tf.lo t.lo libh5test_fortran_la_OBJECTS = $(am_libh5test_fortran_la_OBJECTS) am__EXEEXT_1 = fortranlib_test$(EXEEXT) fflush1$(EXEEXT) \ - fflush2$(EXEEXT) + fflush2$(EXEEXT) fortranlib_test_1_8$(EXEEXT) am_fflush1_OBJECTS = fflush1.$(OBJEXT) fflush1_OBJECTS = $(am_fflush1_OBJECTS) fflush1_LDADD = $(LDADD) @@ -89,8 +87,7 @@ am_fortranlib_test_OBJECTS = \ fortranlib_test-tH5Sselect.$(OBJEXT) \ fortranlib_test-tH5P.$(OBJEXT) fortranlib_test-tH5A.$(OBJEXT) \ fortranlib_test-tH5I.$(OBJEXT) fortranlib_test-tH5G.$(OBJEXT) \ - fortranlib_test-tH5E.$(OBJEXT) fortranlib_test-tf.$(OBJEXT) \ - fortranlib_test-t.$(OBJEXT) + fortranlib_test-tH5E.$(OBJEXT) fortranlib_test_OBJECTS = $(am_fortranlib_test_OBJECTS) fortranlib_test_LDADD = $(LDADD) fortranlib_test_DEPENDENCIES = libh5test_fortran.la $(LIBH5TEST) \ @@ -98,7 +95,14 @@ fortranlib_test_DEPENDENCIES = libh5test_fortran.la $(LIBH5TEST) \ fortranlib_test_LINK = $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ --mode=link $(FCLD) $(fortranlib_test_FCFLAGS) $(FCFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ -DEFAULT_INCLUDES = -I. -I$(top_builddir)/src@am__isrc@ +am_fortranlib_test_1_8_OBJECTS = fortranlib_test_1_8.$(OBJEXT) \ + tH5F.$(OBJEXT) tH5O.$(OBJEXT) tH5A_1_8.$(OBJEXT) \ + tH5G_1_8.$(OBJEXT) +fortranlib_test_1_8_OBJECTS = $(am_fortranlib_test_1_8_OBJECTS) +fortranlib_test_1_8_LDADD = $(LDADD) +fortranlib_test_1_8_DEPENDENCIES = libh5test_fortran.la $(LIBH5TEST) \ + $(LIBH5F) $(LIBHDF5) +DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/src depcomp = $(SHELL) $(top_srcdir)/bin/depcomp am__depfiles_maybe = depfiles COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ @@ -118,9 +122,11 @@ FCLINK = $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link \ $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o \ $@ SOURCES = $(libh5test_fortran_la_SOURCES) $(fflush1_SOURCES) \ - $(fflush2_SOURCES) $(fortranlib_test_SOURCES) + $(fflush2_SOURCES) $(fortranlib_test_SOURCES) \ + $(fortranlib_test_1_8_SOURCES) DIST_SOURCES = $(libh5test_fortran_la_SOURCES) $(fflush1_SOURCES) \ - $(fflush2_SOURCES) $(fortranlib_test_SOURCES) + $(fflush2_SOURCES) $(fortranlib_test_SOURCES) \ + $(fortranlib_test_1_8_SOURCES) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) @@ -145,6 +151,7 @@ CC_VERSION = @CC_VERSION@ # but which shouldn't be exported to h5cc for building other programs. CFLAGS = @CFLAGS@ @H5_CFLAGS@ CLEARFILEBUF = @CLEARFILEBUF@ +CODESTACK = @CODESTACK@ CONFIG_DATE = @CONFIG_DATE@ CONFIG_MODE = @CONFIG_MODE@ CONFIG_USER = @CONFIG_USER@ @@ -160,14 +167,16 @@ DEFAULT_API_VERSION = @DEFAULT_API_VERSION@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ DEPRECATED_SYMBOLS = @DEPRECATED_SYMBOLS@ +DIRECT_VFD = @DIRECT_VFD@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ DYNAMIC_DIRS = @DYNAMIC_DIRS@ -ECHO = @ECHO@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ -F77 = @F77@ +EXTERNAL_FILTERS = @EXTERNAL_FILTERS@ # Make sure that these variables are exported to the Makefiles F9XMODEXT = @F9XMODEXT@ @@ -177,9 +186,10 @@ FC = @FC@ FCFLAGS = @FCFLAGS@ @H5_FCFLAGS@ FCFLAGS_f90 = @FCFLAGS_f90@ FCLIBS = @FCLIBS@ -FFLAGS = @FFLAGS@ +FGREP = @FGREP@ FILTERS = @FILTERS@ FSEARCH_DIRS = @FSEARCH_DIRS@ +GPFS = @GPFS@ GREP = @GREP@ H5_CFLAGS = @H5_CFLAGS@ H5_CPPFLAGS = @H5_CPPFLAGS@ @@ -188,11 +198,14 @@ H5_FCFLAGS = @H5_FCFLAGS@ H5_LONE_COLON = @H5_LONE_COLON@ H5_VERSION = @H5_VERSION@ HADDR_T = @HADDR_T@ +HAVE_DMALLOC = @HAVE_DMALLOC@ +HDF5_HL = @HDF5_HL@ HDF5_INTERFACES = @HDF5_INTERFACES@ +HDF_CXX = @HDF_CXX@ +HDF_FORTRAN = @HDF_FORTRAN@ HID_T = @HID_T@ HL = @HL@ HL_FOR = @HL_FOR@ -HSIZET = @HSIZET@ HSIZE_T = @HSIZE_T@ HSSIZE_T = @HSSIZE_T@ INSTALL = @INSTALL@ @@ -200,11 +213,14 @@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +INSTRUMENT = @INSTRUMENT@ INSTRUMENT_LIBRARY = @INSTRUMENT_LIBRARY@ +LD = @LD@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ +LINUX_LFS = @LINUX_LFS@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ LT_STATIC_EXEC = @LT_STATIC_EXEC@ @@ -213,6 +229,8 @@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ MPE = @MPE@ MPI_GET_SIZE = @MPI_GET_SIZE@ +NM = @NM@ +NMEDIT = @NMEDIT@ OBJECT_NAMELEN_DEFAULT_F = @OBJECT_NAMELEN_DEFAULT_F@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ @@ -232,6 +250,7 @@ RUNSERIAL = @RUNSERIAL@ R_INTEGER = @R_INTEGER@ R_LARGE = @R_LARGE@ SEARCH = @SEARCH@ +SED = @SED@ SETX = @SETX@ SET_MAKE = @SET_MAKE@ @@ -241,13 +260,16 @@ SET_MAKE = @SET_MAKE@ # configure's automatic SHELL detection may not work on the build machine. SHELL = /bin/sh SIZE_T = @SIZE_T@ +STATIC_EXEC = @STATIC_EXEC@ STATIC_SHARED = @STATIC_SHARED@ STRICT_FORMAT_CHECKS = @STRICT_FORMAT_CHECKS@ STRIP = @STRIP@ TESTPARALLEL = @TESTPARALLEL@ +THREADSAFE = @THREADSAFE@ TIME = @TIME@ TR = @TR@ TRACE_API = @TRACE_API@ +UNAME_INFO = @UNAME_INFO@ USE_FILTER_DEFLATE = @USE_FILTER_DEFLATE@ USE_FILTER_FLETCHER32 = @USE_FILTER_FLETCHER32@ USE_FILTER_NBIT = @USE_FILTER_NBIT@ @@ -262,7 +284,7 @@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ -ac_ct_F77 = @ac_ct_F77@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ ac_ct_FC = @ac_ct_FC@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ @@ -280,6 +302,8 @@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = $(exec_prefix)/doc dvidir = @dvidir@ +enable_shared = @enable_shared@ +enable_static = @enable_static@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ @@ -296,6 +320,7 @@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ +lt_ECHO = @lt_ECHO@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ @@ -368,11 +393,8 @@ noinst_LTLIBRARIES = libh5test_fortran.la @FORTRAN_SHARED_CONDITIONAL_FALSE@AM_LDFLAGS = -static # Our main targets, the tests themselves -TEST_PROG = fortranlib_test fflush1 fflush2 -libh5test_fortran_la_SOURCES = fortranlib_test.f90 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 tf.f90 t.c - +TEST_PROG = fortranlib_test fflush1 fflush2 fortranlib_test_1_8 +libh5test_fortran_la_SOURCES = tf.f90 t.c # Source files are used for both the library and fortranlib_test. # Automake will complain about this without the following workaround. @@ -380,8 +402,10 @@ fortranlib_test_FCFLAGS = $(AM_FCFLAGS) fortranlib_test_CFLAGS = $(AM_CFLAGS) fortranlib_test_SOURCES = fortranlib_test.f90 \ 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 tf.f90 \ - t.c + tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90 + +fortranlib_test_1_8_SOURCES = fortranlib_test_1_8.f90 \ + tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90 fflush1_SOURCES = fflush1.f90 fflush2_SOURCES = fflush2.f90 @@ -392,7 +416,7 @@ MOSTLYCLEANFILES = *.tmp # Mark this directory as part of the Fortran API (this affects output # from tests in conclude.am) -HDF_FORTRAN = yes +FORTRAN_API = yes # Automake needs to be taught how to build lib, progs, and tests targets. # These will be filled in automatically for the most part (e.g., @@ -469,6 +493,9 @@ fflush2$(EXEEXT): $(fflush2_OBJECTS) $(fflush2_DEPENDENCIES) fortranlib_test$(EXEEXT): $(fortranlib_test_OBJECTS) $(fortranlib_test_DEPENDENCIES) @rm -f fortranlib_test$(EXEEXT) $(fortranlib_test_LINK) $(fortranlib_test_OBJECTS) $(fortranlib_test_LDADD) $(LIBS) +fortranlib_test_1_8$(EXEEXT): $(fortranlib_test_1_8_OBJECTS) $(fortranlib_test_1_8_DEPENDENCIES) + @rm -f fortranlib_test_1_8$(EXEEXT) + $(FCLINK) $(fortranlib_test_1_8_OBJECTS) $(fortranlib_test_1_8_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) @@ -476,7 +503,6 @@ mostlyclean-compile: distclean-compile: -rm -f *.tab.c -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fortranlib_test-t.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/t.Plo@am__quote@ .c.o: @@ -500,20 +526,6 @@ distclean-compile: @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LTCOMPILE) -c -o $@ $< -fortranlib_test-t.o: t.c -@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(fortranlib_test_CFLAGS) $(CFLAGS) -MT fortranlib_test-t.o -MD -MP -MF $(DEPDIR)/fortranlib_test-t.Tpo -c -o fortranlib_test-t.o `test -f 't.c' || echo '$(srcdir)/'`t.c -@am__fastdepCC_TRUE@ mv -f $(DEPDIR)/fortranlib_test-t.Tpo $(DEPDIR)/fortranlib_test-t.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='t.c' object='fortranlib_test-t.o' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(fortranlib_test_CFLAGS) $(CFLAGS) -c -o fortranlib_test-t.o `test -f 't.c' || echo '$(srcdir)/'`t.c - -fortranlib_test-t.obj: t.c -@am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(fortranlib_test_CFLAGS) $(CFLAGS) -MT fortranlib_test-t.obj -MD -MP -MF $(DEPDIR)/fortranlib_test-t.Tpo -c -o fortranlib_test-t.obj `if test -f 't.c'; then $(CYGPATH_W) 't.c'; else $(CYGPATH_W) '$(srcdir)/t.c'; fi` -@am__fastdepCC_TRUE@ mv -f $(DEPDIR)/fortranlib_test-t.Tpo $(DEPDIR)/fortranlib_test-t.Po -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='t.c' object='fortranlib_test-t.obj' libtool=no @AMDEPBACKSLASH@ -@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ -@am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(fortranlib_test_CFLAGS) $(CFLAGS) -c -o fortranlib_test-t.obj `if test -f 't.c'; then $(CYGPATH_W) 't.c'; else $(CYGPATH_W) '$(srcdir)/t.c'; fi` - .f90.o: $(FCCOMPILE) -c -o $@ $< @@ -607,12 +619,6 @@ fortranlib_test-tH5E.o: tH5E.f90 fortranlib_test-tH5E.obj: tH5E.f90 $(FC) $(fortranlib_test_FCFLAGS) $(FCFLAGS) -c -o fortranlib_test-tH5E.obj `if test -f 'tH5E.f90'; then $(CYGPATH_W) 'tH5E.f90'; else $(CYGPATH_W) '$(srcdir)/tH5E.f90'; fi` -fortranlib_test-tf.o: tf.f90 - $(FC) $(fortranlib_test_FCFLAGS) $(FCFLAGS) -c -o fortranlib_test-tf.o `test -f 'tf.f90' || echo '$(srcdir)/'`tf.f90 - -fortranlib_test-tf.obj: tf.f90 - $(FC) $(fortranlib_test_FCFLAGS) $(FCFLAGS) -c -o fortranlib_test-tf.obj `if test -f 'tf.f90'; then $(CYGPATH_W) 'tf.f90'; else $(CYGPATH_W) '$(srcdir)/tf.f90'; fi` - mostlyclean-libtool: -rm -f *.lo @@ -624,8 +630,8 @@ ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ - $(AWK) ' { files[$$0] = 1; } \ - END { for (i in files) print i; }'`; \ + $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS @@ -637,8 +643,8 @@ TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ - $(AWK) ' { files[$$0] = 1; } \ - END { for (i in files) print i; }'`; \ + $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ @@ -648,13 +654,12 @@ ctags: CTAGS CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) tags=; \ - here=`pwd`; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ - $(AWK) ' { files[$$0] = 1; } \ - END { for (i in files) print i; }'`; \ + $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$tags$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$tags $$unique @@ -902,10 +907,10 @@ $(TEST_PROG_CHKEXE) $(TEST_PROG_PARA_CHKEXE) dummy.chkexe_: echo "No need to test $${tname} again."; \ else \ echo "============================" > $${log}; \ - if test "X$(HDF_FORTRAN)" = "Xyes"; then \ + if test "X$(FORTRAN_API)" = "Xyes"; then \ echo "Fortran API: Testing $(HDF5_DRIVER) $${tname} $(TEST_FLAGS)"; \ echo "Fortran API: $(HDF5_DRIVER) $${tname} $(TEST_FLAGS) Test Log" >> $${log}; \ - elif test "X$(HDF_CXX)" = "Xyes"; then \ + elif test "X$(CXX_API)" = "Xyes"; then \ echo "C++ API: Testing $(HDF5_DRIVER) $${tname} $(TEST_FLAGS)"; \ echo "C++ API: $(HDF5_DRIVER) $${tname} $(TEST_FLAGS) Test Log" >> $${log};\ else \ @@ -941,10 +946,10 @@ $(TEST_SCRIPT_CHKSH) $(TEST_SCRIPT_PARA_CHKSH) dummysh.chkexe_: echo "No need to test $${tname} again."; \ else \ echo "============================" > $${log}; \ - if test "X$(HDF_FORTRAN)" = "Xyes"; then \ + if test "X$(FORTRAN_API)" = "Xyes"; then \ echo "Fortran API: Testing $${tname} $(TEST_FLAGS)"; \ echo "Fortran API: $${tname} $(TEST_FLAGS) Test Log" >> $${log}; \ - elif test "X$(HDF_CXX)" = "Xyes"; then \ + elif test "X$(CXX_API)" = "Xyes"; then \ echo "C++ API: Testing $${tname} $(TEST_FLAGS)"; \ echo "C++ API: $${tname} $(TEST_FLAGS) Test Log" >> $${log}; \ else \ diff --git a/fortran/test/fflush1.f90 b/fortran/test/fflush1.f90 index 44c4195..f42ae6e 100644 --- a/fortran/test/fflush1.f90 +++ b/fortran/test/fflush1.f90 @@ -58,12 +58,6 @@ ! data space identifier ! INTEGER(HID_T) :: dataspace - - ! - ! data type identifier - ! - INTEGER(HID_T) :: dtype_id - ! !The dimensions for the dataset. ! @@ -82,7 +76,7 @@ ! !data buffers ! - INTEGER, DIMENSION(NX,NY) :: data_in, data_out + INTEGER, DIMENSION(NX,NY) :: data_in INTEGER(HSIZE_T), DIMENSION(2) :: data_dims data_dims(1) = NX data_dims(2) = NY diff --git a/fortran/test/fflush2.f90 b/fortran/test/fflush2.f90 index 0414d37..38a2bd7 100644 --- a/fortran/test/fflush2.f90 +++ b/fortran/test/fflush2.f90 @@ -50,22 +50,13 @@ ! 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/) - ! !flag to check operation success ! diff --git a/fortran/test/fortranlib_test_1_8.f90 b/fortran/test/fortranlib_test_1_8.f90 new file mode 100644 index 0000000..ac87272 --- /dev/null +++ b/fortran/test/fortranlib_test_1_8.f90 @@ -0,0 +1,447 @@ +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! 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. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! +! Testing Fortran wrappers introduced in 1.8 release. +! +PROGRAM fortranlibtest + + USE HDF5 + + IMPLICIT NONE + INTEGER :: total_error = 0 + INTEGER :: error + INTEGER :: ret_total_error + INTEGER :: majnum, minnum, relnum + CHARACTER(LEN=8) error_string + CHARACTER(LEN=8) :: success = ' PASSED ' + CHARACTER(LEN=8) :: failure = '*FAILED*' + CHARACTER(LEN=4) :: e_format ='(8a)' + LOGICAL :: cleanup = .TRUE. +! LOGICAL :: cleanup = .FALSE. + + CALL h5open_f(error) + 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(*,*) + + ret_total_error = 0 + error_string = failure + CALL file_space(cleanup, ret_total_error) + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = '(21a)', advance = 'no') ' Testing file free space' + WRITE(*, fmt = '(52x,a)', advance = 'no') ' ' + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + ! write(*,*) + ! write(*,*) '=========================================' + ! write(*,*) 'Testing ATTRIBUTE interface ' + ! write(*,*) '=========================================' + + ret_total_error = 0 + error_string = failure + CALL attribute_test_1_8(cleanup, ret_total_error) + WRITE(*, fmt = '(15a)', advance = 'no') ' Testing attributes' + WRITE(*, fmt = '(57x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + + ret_total_error = 0 + error_string = failure + CALL group_test(cleanup, ret_total_error) + WRITE(*, fmt = '(15a)', advance = 'no') ' Testing groups' + WRITE(*, fmt = '(61x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + + ret_total_error = 0 + error_string = failure + CALL test_h5o(cleanup, ret_total_error) + WRITE(*, fmt = '(15a)', advance = 'no') ' Testing object interface' + WRITE(*, fmt = '(51x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + + ret_total_error = 0 + error_string = failure + CALL dtransform(cleanup, ret_total_error) + WRITE(*, fmt = '(15a)', advance = 'no') ' Testing data transform' + WRITE(*, fmt = '(53x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + + ret_total_error = 0 + error_string = failure + CALL test_genprop_basic_class(cleanup, ret_total_error) + WRITE(*, fmt = '(30a)', advance = 'no') ' Testing basic generic properties' + WRITE(*, fmt = '(43x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + + CALL test_h5s_encode(cleanup, ret_total_error) + WRITE(*, fmt = '(15a)', advance = 'no') ' Testing dataspace encoding and decoding' + WRITE(*, fmt = '(36x,a)', advance = 'no') ' ' + IF (ret_total_error == 0) error_string = success + WRITE(*, fmt = e_format) error_string + total_error = total_error + ret_total_error + +! CALL test_hard_query(group_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 + +SUBROUTINE dtransform(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: dxpl_id_c_to_f, dxpl_id_c_to_f_copy + INTEGER(HID_T) :: dxpl_id_simple, dxpl_id_polynomial, dxpl_id_polynomial_copy, dxpl_id_utrans_inv, 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 VerifyString("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 VerifyString("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 VerifyString("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(cleanup, total_error) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(HID_T) :: cid1 !/* Generic Property class ID */ + INTEGER(HID_T) :: cid2 !/* Generic Property class ID */ + INTEGER(HID_T) :: cid3 !/* 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" + + ! /* 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 verifystring("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 verifystring("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 verifystring("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 verifylogical("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 verifylogical("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(cleanup, total_error) + +!/**************************************************************** +!** +!** test_h5s_encode(): Test H5S (dataspace) encoding and decoding. +!** +!****************************************************************/ + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(INOUT) :: total_error + + INTEGER(hid_t) :: sid1, sid2, sid3! /* Dataspace ID */ + INTEGER(hid_t) :: decoded_sid1, decoded_sid2, decoded_sid3 + INTEGER :: rank !/* LOGICAL rank of dataspace */ + INTEGER(size_t) :: sbuf_size=0, null_size=0, scalar_size=0 + +! Make sure the size is large, need variable length in fortran 2003 + CHARACTER(LEN=288) :: sbuf + CHARACTER(LEN=288) :: scalar_buf +! F2003 CHARACTER(LEN=:), ALLOCATABLE :: sbuf + +! unsigned char *sbuf=NULL, *null_sbuf=NULL, *scalar_buf=NULL; +! hsize_t tdims[4]; /* Dimension array to test with */ + 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 + +! H5S_sel_type sel_type; +! hssize_t nblocks; + ! + !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 + + !/* Output message about test being performed */ + !WRITE(*,*) "Testing Dataspace Encoding and Decoding" + + !/*------------------------------------------------------------------------- + ! * 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) + + ! In fortran 2003 we can allocate the needed character size here + + ! /* 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), SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3, & + total_error) + +!!$ +!!$ rank = H5Sget_simple_extent_ndims(decoded_sid1); +!!$ CHECK(rank, FAIL, "H5Sget_simple_extent_ndims"); +!!$ VERIFY(rank, SPACE1_RANK, "H5Sget_simple_extent_ndims"); +!!$ +!!$ rank = H5Sget_simple_extent_dims(decoded_sid1, tdims, NULL); +!!$ CHECK(rank, FAIL, "H5Sget_simple_extent_dims"); +!!$ VERIFY(HDmemcmp(tdims, dims1, SPACE1_RANK * sizeof(hsize_t)), 0, +!!$ "H5Sget_simple_extent_dims"); +!!$ +!!$ /* Verify hyperslabe selection */ +!!$ sel_type = H5Sget_select_type(decoded_sid1); +!!$ VERIFY(sel_type, H5S_SEL_HYPERSLABS, "H5Sget_select_type"); +!!$ +!!$ nblocks = H5Sget_select_hyper_nblocks(decoded_sid1); +!!$ VERIFY(nblocks, 2*2*2, "H5Sget_select_hyper_nblocks"); +!!$ + ! + !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 + diff --git a/fortran/test/tH5A.f90 b/fortran/test/tH5A.f90 index 44c7964..b73dd8a 100644 --- a/fortran/test/tH5A.f90 +++ b/fortran/test/tH5A.f90 @@ -56,10 +56,7 @@ 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) :: aspace3_id !Double Attribute Dataspace identifier - INTEGER(HID_T) :: aspace4_id !Real Attribute Dataspace identifier - INTEGER(HID_T) :: aspace5_id !Integer 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 @@ -79,7 +76,8 @@ 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 :: 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 @@ -113,32 +111,32 @@ ! !data buffers ! - INTEGER, DIMENSION(NX,NY) :: data_in, data_out + INTEGER, DIMENSION(NX,NY) :: data_in ! !Initialize data_in buffer ! - do i = 1, NX - do j = 1, NY + DO i = 1, NX + DO j = 1, NY data_in(i,j) = (i-1) + (j-1) - end do - end do + 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)) + 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 + 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) @@ -247,8 +245,10 @@ ! ! 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) ! @@ -287,6 +287,29 @@ ! 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. @@ -383,12 +406,12 @@ ! 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 + IF (attr_name(1:12) .NE. aname5) THEN total_error = total_error + 1 - end if - if (error .ne. 12) then + END IF + IF (error .NE. 12) THEN total_error = total_error + 1 - end if + END IF ! !get the STRING attrbute space @@ -438,10 +461,10 @@ ! 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 + IF (num_attrs .NE. 6) THEN + WRITE(*,*) "got number of attributes wrong", num_attrs total_error = total_error +1 - end if + END IF ! !set the read back data type's size @@ -458,60 +481,60 @@ 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) + 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 + 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 + IF (aread_character_data .NE. 'A' ) THEN + WRITE(*,*) "Read back character attrbute is wrong ",aread_character_data total_error = total_error + 1 - end if + 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) - if (aread_double_data(1) .ne. 3.459 ) then - write(*,*) "Read back double attrbute is wrong", aread_double_data(1) + IF (aread_double_data(1) .NE. 3.459 ) THEN + WRITE(*,*) "Read back double attrbute is wrong", aread_double_data(1) total_error = total_error + 1 - end if + END IF ! !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) - if (aread_real_data(1) .ne. 4.0 ) then - write(*,*) "Read back real attrbute is wrong ", aread_real_data + IF (aread_real_data(1) .NE. 4.0 ) THEN + WRITE(*,*) "Read back real attrbute is wrong ", aread_real_data total_error = total_error + 1 - end if + END IF ! !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 + 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 + 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 + 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 + END IF ! ! Close the attribute. @@ -540,10 +563,10 @@ ! 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 + IF (num_attrs .NE. 5) THEN + WRITE(*,*) "got number of attributes wrong", num_attrs total_error = total_error +1 - end if + END IF @@ -582,7 +605,7 @@ ! ! Remove the file ! - if (cleanup) call h5_cleanup_f(filename, H5P_DEFAULT_F, error) + IF (cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) RETURN END SUBROUTINE attribute_test diff --git a/fortran/test/tH5A_1_8.f90 b/fortran/test/tH5A_1_8.f90 new file mode 100644 index 0000000..cbd1840 --- /dev/null +++ b/fortran/test/tH5A_1_8.f90 @@ -0,0 +1,3279 @@ +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! 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. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +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 +! + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + CHARACTER(LEN=5), PARAMETER :: filename = "atest" !File name + 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 + + ! + !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./) + + +! ******************** +! 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(*,*) " - Testing with new file format" + my_fapl = fapl2 + ELSE +! WRITE(*,*) " - Testing with old file format" + my_fapl = fapl + END IF + CALL test_attr_basic_write(my_fapl, total_error) +!!$ CALL test_attr_basic_read(my_fapl) +!!$ CALL test_attr_flush(my_fapl) +!!$ CALL test_attr_plist(my_fapl) ! this is next +!!$ CALL test_attr_compound_write(my_fapl) +!!$ CALL test_attr_compound_read(my_fapl) +!!$ CALL test_attr_scalar_write(my_fapl) +!!$ CALL test_attr_scalar_read(my_fapl) +!!$ CALL test_attr_mult_write(my_fapl) +!!$ CALL test_attr_mult_read(my_fapl) +!!$ CALL test_attr_iterate(my_fapl) +!!$ CALL test_attr_delete(my_fapl) +!!$ CALL test_attr_dtype_shared(my_fapl) + 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 +!!$ CALL test_attr_dense_create(my_fcpl, my_fapl) + CALL test_attr_dense_open(my_fcpl, my_fapl, total_error) +!!$ CALL test_attr_dense_delete(my_fcpl, my_fapl) +!!$ CALL test_attr_dense_rename(my_fcpl, my_fapl) +!!$ CALL test_attr_dense_unlink(my_fcpl, my_fapl) +!!$ CALL test_attr_dense_limits(my_fcpl, my_fapl) +!!$ CALL test_attr_big(my_fcpl, my_fapl) + CALL test_attr_null_space(my_fcpl, my_fapl, total_error) +!!$ CALL test_attr_deprec(fcpl, my_fapl) + CALL test_attr_many(new_format(i), my_fcpl, my_fapl, total_error) + CALL test_attr_corder_create_basic(my_fcpl, my_fapl, total_error) + CALL test_attr_corder_create_compact(my_fcpl, my_fapl, total_error) +!!$ CALL test_attr_corder_create_dense(my_fcpl, my_fapl) +!!$ CALL test_attr_corder_create_reopen(my_fcpl, my_fapl) +!!$ CALL test_attr_corder_transition(my_fcpl, my_fapl) +!!$ CALL test_attr_corder_delete(my_fcpl, my_fapl) + CALL test_attr_info_by_idx(new_format, my_fcpl, my_fapl, total_error) + CALL test_attr_delete_by_idx(new_format, my_fcpl, my_fapl, total_error) +!!$ CALL test_attr_iterate2(new_format, my_fcpl, my_fapl) +!!$ CALL test_attr_open_by_idx(new_format, my_fcpl, my_fapl) +!!$ CALL test_attr_open_by_name(new_format, my_fcpl, my_fapl) + CALL test_attr_create_by_name(new_format(i), my_fcpl, my_fapl, total_error) + ! /* More complex tests with both "new format" and "shared" attributes */ + IF( use_shared(j) ) THEN +!!$ CALL test_attr_shared_write(my_fcpl, my_fapl) + CALL test_attr_shared_rename(my_fcpl, my_fapl, total_error) + CALL test_attr_shared_delete(my_fcpl, my_fapl, total_error) +!!$ CALL test_attr_shared_unlink(my_fcpl, my_fapl) + END IF +!!$ CALL test_attr_bug1(my_fcpl, my_fapl) + END DO +!!$ ELSE +!!$ CALL test_attr_big(fcpl, my_fapl) +!!$ CALL test_attr_null_space(fcpl, my_fapl) +!!$ CALL test_attr_deprec(fcpl, my_fapl) +!!$ CALL test_attr_many(new_format, fcpl, my_fapl) +!!$ CALL test_attr_info_by_idx(new_format, fcpl, my_fapl) +!!$ CALL test_attr_delete_by_idx(new_format, fcpl, my_fapl) +!!$ CALL test_attr_iterate2(new_format, fcpl, my_fapl) +!!$ CALL test_attr_open_by_idx(new_format, fcpl, my_fapl) +!!$ CALL test_attr_open_by_name(new_format, fcpl, my_fapl) +!!$ CALL test_attr_create_by_name(new_format, fcpl, my_fapl) +!!$ CALL test_attr_bug1(fcpl, my_fapl) + + END IF + END DO + + 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) + +! Needed for get_info_by_name + + USE HDF5 ! This module contains all necessary modules + + 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 +! CASE DEFAULT +! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT +!!$ is_empty = H5O_is_attr_empty_test(my_dataset) +!!$ CALL VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test") +!!$ is_dense = H5O_is_attr_dense_test(my_dataset) +!!$ CALL VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test") + 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) + +!!$ ret = H5O_num_attrs_test(my_dataset, nattrs) +!!$ CALL CHECK(ret, FAIL, "H5O_num_attrs_test") +!!$ CALL VERIFY(nattrs, (u + 1)) +!!$ is_empty = H5O_is_attr_empty_test(my_dataset) +!!$ CALL VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test") +!!$ is_dense = H5O_is_attr_dense_test(my_dataset) +!!$ CALL VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test") + 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 +!!$ ret = H5O_num_attrs_test(my_dataset, nattrs) +!!$ CALL CHECK(ret, FAIL, "H5O_num_attrs_test") +!!$ CALL VERIFY(nattrs, max_compact, "H5O_num_attrs_test") +!!$ is_empty = H5O_is_attr_empty_test(my_dataset) +!!$ CALL VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test") +!!$ is_dense = H5O_is_attr_dense_test(my_dataset) +!!$ CALL VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test") + + 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 verifyLogical("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 verifyLogical("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 +!** +!****************************************************************/ + USE HDF5 + 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, PARAMETER :: NUM_DSETS = 3 + + + 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 + + ! /* Output message about test being performed */ +! WRITE(*,*) " - Testing Storing Attributes with 'null' dataspace" + ! /* 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 + 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 Verifylogical("H5Sextent_equal_f",equal,.TRUE.,total_error) + +!!$ ret = H5Sclose(attr_sid) +!!$ CALL CHECK(ret, FAIL, "H5Sclose") + + 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) + + USE HDF5 + + 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 + + ! /* Check on dataset's attribute storage status */ +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + !/* 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, total_error) + ! CALL check("FAILED IN attr_info_by_idx_check",total_error) + ENDDO + + ! /* Verify state of object */ +!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs); +!!$ CHECK(ret, FAIL, "H5O_num_attrs_test"); +!!$ VERIFY(nattrs, max_compact, "H5O_num_attrs_test"); +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + ! /* 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) + + ! /* Verify state of object */ +!!$ if(u >= max_compact) { +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test"); +!!$ } /* end if */ +!!$ +!!$ /* Verify information for new attribute */ +!!$ ret = attr_info_by_idx_check(my_dataset, attrname, (hsize_t)u, use_index); +!!$ CHECK(ret, FAIL, "attr_info_by_idx_check"); + ENDDO + + ! /* Verify state of object */ +!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs); +!!$ CHECK(ret, FAIL, "H5O_num_attrs_test"); +!!$ VERIFY(nattrs, (max_compact * 2), "H5O_num_attrs_test"); +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test"); + +!!$ if(new_format) { +!!$ /* Retrieve & verify # of records in the name & creation order indices */ +!!$ ret = H5O_attr_dense_info_test(my_dataset, &name_count, &corder_count); +!!$ CHECK(ret, FAIL, "H5O_attr_dense_info_test"); +!!$ if(use_index) +!!$ VERIFY(name_count, corder_count, "H5O_attr_dense_info_test"); +!!$ VERIFY(name_count, (max_compact * 2), "H5O_attr_dense_info_test"); +!!$ } /* end if */ + +!!$ /* Test opening attributes stored compactly */ +!!$ ret = attr_open_check(fid, dsetname, my_dataset, u); +!!$ CHECK(ret, FAIL, "attr_open_check"); + + 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) + + USE HDF5 + + 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 + + ! /* Output message about test being performed */ +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(A72)') " - Testing Querying Attribute Info By Index w/Creation Order Index" +!!$ ELSE +!!$ WRITE(*,'(A74)') " - Testing Querying Attribute Info By Index 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 ) + 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 + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + END SELECT + + !/* Check on dataset's attribute storage status */ +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + ! /* 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 + + ! attr = H5Acreate2(my_dataset, attrname, H5T_NATIVE_UINT, sid, H5P_DEFAULT, H5P_DEFAULT); + ! 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 ) + + USE HDF5 + + 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 HDmemset(ainfo, 0, SIZEOF(ainfo) + 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) +!!$ ret = H5Aget_name_by_idx(obj_id, ".", H5_INDEX_NAME, H5_ITER_INC, n, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) +!!$ CALL CHECK(ret, FAIL, "H5Aget_name_by_idx") +!!$ IF (HDstrcmp(attrname, tmpname)) CALL TestErrPrintf("Line %d: attribute name size wrong!\n"C, __LINE__) + 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) +!!$ ret = H5Aget_name_by_idx(obj_id, ".", H5_INDEX_NAME, H5_ITER_DEC, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) +!!$ CALL CHECK(ret, FAIL, "H5Aget_name_by_idx") +!!$ IF (HDstrcmp(attrname, tmpname)) CALL TestErrPrintf("Line %d: attribute name size wrong!\n"C, __LINE__) + +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 +!** +!****************************************************************/ + + USE HDF5 + + 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, PARAMETER :: NUM_DSETS = 3 + + + 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 + + CHARACTER(LEN=1), PARAMETER :: chr1 = '.' + + INTEGER :: u + INTEGER, PARAMETER :: SPACE1_RANK = 3 + INTEGER, PARAMETER :: NX = 20 + INTEGER, PARAMETER :: NY = 5 + INTEGER, PARAMETER :: NZ = 10 + INTEGER(HID_T) :: my_fcpl + + CHARACTER(LEN=5), PARAMETER :: TYPE1_NAME = "/Type" + + INTEGER, PARAMETER :: SPACE1_DIM1 = 4 + INTEGER, PARAMETER :: SPACE1_DIM2 = 8 + INTEGER, PARAMETER :: SPACE1_DIM3 = 10 + + + INTEGER :: test_shared + INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension + INTEGER :: arank = 1 ! Attribure rank + + ! /* Output message about test being performed */ +! WRITE(*,*) " - Testing Renaming Shared & Unshared Attributes in Compact & Dense Storage" +!!$ /* 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) + + ! /* Check on dataset's message storage status */ +!!$ if(test_shared != 0) { +!!$ /* Datasets' datatypes can be shared */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 1, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ /* Datasets' dataspace can be shared */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 1, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ + + ! /* 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) +!!$ +!!$ +!!$ /* Check on datasets' attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ is_dense = H5O_is_attr_dense_test(dataset2); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + ! /* 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) + +!!$ /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); + + ! /* 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) + + ! Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); + + ! Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ + ! 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) + + ! Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); + ENDIF + + ! /* Close attribute */ + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ if(u < max_compact) +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ else +!!$ VERIFY(is_dense, TRUE, "H5O_is_attr_dense_test"); +!!$ +!!$ + ! /* 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) + + ! /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ + ! /* 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) + +! /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +! /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ +! /* 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 */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 2, "H5A_get_shared_rc_test"); + + ENDIF + ! /* Close attribute */ + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset2); +!!$ if(u < max_compact) +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ else +!!$ VERIFY(is_dense, TRUE, "H5O_is_attr_dense_test"); + + + ! /* 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) + +!!$ +!!$ IF(MOD(u+1,2).EQ.0)THEN +!!$ ! /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ CALL VERIFY("H5A_is_shared_test", error, minusone) +!!$ ELSE +!!$ ! /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +!!$ /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test") +!!$ ENDIF + + ! /* 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) + +!!$ if(u % 2) { +!!$ /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ } /* end if */ +!!$ else { +!!$ /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +!!$ /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ } /* end else */ + + ! /* 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) +!!$ +!!$ if(u % 2) { +!!$ /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ } /* end if */ +!!$ else { +!!$ /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +!!$ /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 2, "H5A_get_shared_rc_test"); +!!$ } /* end else */ + + ! /* 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) + +!!$ if(u % 2) { +!!$ /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ } /* end if */ +!!$ else { +!!$ /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +!!$ /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 2, "H5A_get_shared_rc_test"); +!!$ } /* end else */ + + ! /* 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) + +!!$ /* Check on shared message status now */ +!!$ if(test_shared != 0) { +!!$ if(test_shared == 1) { +!!$ /* Check on datatype storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 2, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ +!!$ +!!$ /* Check on dataspace storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 2, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ + + ! /* 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 + + ! /* Check on attribute storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_ATTR_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ if(test_shared != 0) { +!!$ /* Check on datatype storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ /* Check on dataspace storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ + + ! /* 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) + + USE HDF5 + + 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 + CHARACTER(LEN=1), PARAMETER :: chr1 = '.' + + 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 + + ! /* Print appropriate test message */ +!!$ IF(idx_type .EQ. H5_INDEX_CRT_ORDER_F)THEN +!!$ IF(order .EQ. H5_ITER_INC_F) THEN +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(A102)') & +!!$ " - Testing Deleting Attribute By Creation Order Index in Increasing Order w/Creation Order Index" +!!$ ELSE +!!$ WRITE(*,'(A104)') & +!!$ " - Testing Deleting Attribute By Creation Order Index in Increasing Order w/o Creation Order Index" +!!$ ENDIF +!!$ ELSE +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(A102)') & +!!$ " - Testing Deleting Attribute By Creation Order Index in Decreasing Order w/Creation Order Index" +!!$ ELSE +!!$ WRITE(*,'(A104)') & +!!$ " - Testing Deleting Attribute By Creation Order Index in Decreasing Order w/o Creation Order Index" +!!$ ENDIF +!!$ ENDIF +!!$ ELSE +!!$ IF(order .EQ. H5_ITER_INC_F)THEN +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(7X,A86)')"- Testing Deleting Attribute By Name Index in Increasing Order w/Creation Order Index" +!!$ ELSE +!!$ WRITE(*,'(7X,A88)')"- Testing Deleting Attribute By Name Index in Increasing Order w/o Creation Order Index" +!!$ ENDIF +!!$ ELSE +!!$ IF(use_index(i))THEN +!!$ WRITE(*,'(7X,A86)') "- Testing Deleting Attribute By Name Index in Decreasing Order w/Creation Order Index" +!!$ ELSE +!!$ WRITE(*,'(7X,A88)') "- Testing Deleting Attribute By Name Index in Decreasing Order w/o Creation Order Index" +!!$ ENDIF +!!$ ENDIF +!!$ 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 ) + 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 on dataset's attribute storage status */ +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + ! /* 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 + + + + ! /* Verify state of object */ + +!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs); +!!$ CHECK(ret, FAIL, "H5O_num_attrs_test"); +!!$ VERIFY(nattrs, max_compact, "H5O_num_attrs_test"); +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + !/* 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 */ + ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); + + 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) + + + ! /* Verify state of attribute storage (empty) */ +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test"); + 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) + + ! /* Verify state of object */ + IF(u .GE. max_compact)THEN +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test"); + ENDIF + + ! /* Verify information for new attribute */ +!!$ CALL check("attr_info_by_idx_check",error,total_error) + ENDDO + + ! /* Verify state of object */ +!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs); +!!$ CHECK(ret, FAIL, "H5O_num_attrs_test"); +!!$ VERIFY(nattrs, (max_compact * 2), "H5O_num_attrs_test"); +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test"); +!!$ is_dense = H5O_is_attr_dense_test(my_dataset); +!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test"); +!!$ + IF(new_format)THEN +!!$ ! /* Retrieve & verify # of records in the name & creation order indices */ +!!$ ret = H5O_attr_dense_info_test(my_dataset, &name_count, &corder_count); +!!$ CHECK(ret, FAIL, "H5O_attr_dense_info_test"); +!!$ IF(use_index) +!!$ VERIFY(name_count, corder_count, "H5O_attr_dense_info_test"); +!!$ VERIFY(name_count, (max_compact * 2), "H5O_attr_dense_info_test"); + ENDIF + + ! /* 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 + ! CASE DEFAULT + ! CALL HDassert(0.AND."Toomanydatasets!") + 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) + ! /* Verify state of attribute storage (empty) */ +!!$ is_empty = H5O_is_attr_empty_test(my_dataset); +!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test"); + + !/* 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 +!** +!****************************************************************/ + + USE HDF5 + + 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, PARAMETER :: NUM_DSETS = 3 + + + 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=1), PARAMETER :: chr1 = '.' + + INTEGER :: u + INTEGER, PARAMETER :: SPACE1_RANK = 3 + INTEGER, PARAMETER :: NX = 20 + INTEGER, PARAMETER :: NY = 5 + INTEGER, PARAMETER :: NZ = 10 + 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 */ +! WRITE(*,*) " - Testing Deleting Shared & Unshared Attributes in Compact & Dense Storage" + + ! /* 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) +!!$ CHECK_I(ret, "H5Pset_shared_mesg_nindexes"); + 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) + +!!$ CHECK_I(ret, "H5Pset_shared_mesg_index"); + 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) +!!$ CHECK_I(ret, "H5Pset_shared_mesg_index"); + 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) + + ! /* Check on dataset's message storage status */ +!!$ if(test_shared != 0) { +!!$ /* Datasets' datatypes can be shared */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 1, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ /* Datasets' dataspace can be shared */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 1, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ +!!$ + ! /* 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) +!!$ +!!$ /* Check on datasets' attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ is_dense = H5O_is_attr_dense_test(dataset2); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ + ! /* 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) + +!!$ /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); + + ! /* 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) +!!$ + ! Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); + + ! Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ + ! 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 */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); + ENDIF + + ! /* Close attribute */ + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ if(u < max_compact) +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ else +!!$ VERIFY(is_dense, TRUE, "H5O_is_attr_dense_test"); +!!$ +!!$ + ! /* 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) + + ! /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ + ! /* 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) + +! /* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +! /* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ +! /* 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 */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 2, "H5A_get_shared_rc_test"); + + ENDIF + ! /* Close attribute */ + CALL h5aclose_f(attr, error) + CALL check("h5aclose_f",error,total_error) + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset2); +!!$ if(u < max_compact) +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); +!!$ else +!!$ VERIFY(is_dense, TRUE, "H5O_is_attr_dense_test"); + 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) + +!!$ /* Check refcount on attributes now */ +!!$ +!!$ /* Check refcount on first dataset's attribute */ + + CALL h5aopen_f(dataset, attrname, attr, error, aapl_id=H5P_DEFAULT_F) + CALL check("h5aopen_f",error,total_error) + +!!$ +!!$ if(u % 2) { +! /* Check that attribute is not shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, FALSE, "H5A_is_shared_test"); +!!$ } /* end if */ +!!$ else { +!/* Check that attribute is shared */ +!!$ is_shared = H5A_is_shared_test(attr); +!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test"); +!!$ +!/* Check refcount for attribute */ +!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount); +!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test"); +!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test"); +!!$ } /* end else */ + + ! /* 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) + + ! /* Check on shared message status now */ +!!$ if(test_shared != 0) { +!!$ if(test_shared == 1) { + ! /* Check on datatype storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 2, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ +!!$ +!!$ /* Check on dataspace storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 2, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ +!!$ + ! /* 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 + + ! /* Check on attribute storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_ATTR_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ if(test_shared != 0) { +!!$ /* Check on datatype storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_DTYPE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ +!!$ /* Check on dataspace storage status */ +!!$ ret = H5F_get_sohm_mesg_count_test(fid, H5O_SDSPACE_ID, &mesg_count); +!!$ CHECK(ret, FAIL, "H5F_get_sohm_mesg_count_test"); +!!$ VERIFY(mesg_count, 0, "H5F_get_sohm_mesg_count_test"); +!!$ } /* end if */ +!!$ + + ! /* 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_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 +!** +!****************************************************************/ + + USE HDF5 + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(IN) :: 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 + + ! /* Output message about test being performed */ +! WRITE(*,*) " - Testing Opening Attributes in Dense Storage" + + ! /* 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) + + ! /* Check on dataset's attribute storage status */ + ! is_dense = H5O_is_attr_dense_test(dataset); + ! VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + + ! /* 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) + ! CHECK(ret, FAIL, "test_attr_dense_verify"); + ENDDO + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test"); + +! /* 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) + + ! /* Check on dataset's attribute storage status */ +!!$ is_dense = H5O_is_attr_dense_test(dataset); +!!$ VERIFY(is_dense, TRUE, "H5O_is_attr_dense_test"); + + + ! /* 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) + + USE HDF5 + + 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 ) + + USE HDF5 + + IMPLICIT NONE + + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(IN) :: 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) + + USE HDF5 + + 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 + INTEGER(HSIZE_T), DIMENSION(7) :: data_dims + + CHARACTER(LEN=25) :: check_name + CHARACTER(LEN=18) :: chr_exact_size + + INTEGER, PARAMETER :: SPACE1_RANK = 2 + + 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 + + ! /* Output message about test being performed */ +! WRITE(*,*) " - Testing Basic Scalar Attribute Writing Functions" + + ! /* 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) + +! attr_size = H5Aget_storage_size(attr); +! VERIFY(attr_size, (ATTR1_DIM1 * sizeof(int)), "H5A_get_storage_size"); + + ! /* 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 VerifyString('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) + + USE HDF5 + + IMPLICIT NONE + + LOGICAL, INTENT(IN) :: new_format + INTEGER(HID_T), INTENT(IN) :: fcpl + INTEGER(HID_T), INTENT(IN) :: fapl + INTEGER, INTENT(IN) :: 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 + + ! /* Output message about test being performed */ +! WRITE(*,*) " - Testing Storing Many Attributes" + + !/* 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 VerifyLogical("H5Aexists",exists,.FALSE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error, lapl_id = H5P_DEFAULT_F) + CALL VerifyLogical("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 VerifyLogical("H5Aexists",exists,.TRUE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) + CALL VerifyLogical("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 VerifyLogical("H5Aexists",exists,.TRUE.,total_error ) + + CALL H5Aexists_by_name_f(fid, GROUP1_NAME, attrname, exists, error) + CALL VerifyLogical("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 ) + + USE HDF5 + + 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, PARAMETER :: NUM_DSETS = 3 + 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 Verifylogical("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 Verifylogical("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 Verifylogical("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 diff --git a/fortran/test/tH5F.f90 b/fortran/test/tH5F.f90 index 77c5fe8..859d66e 100644 --- a/fortran/test/tH5F.f90 +++ b/fortran/test/tH5F.f90 @@ -697,8 +697,6 @@ LOGICAL, INTENT(IN) :: cleanup INTEGER, INTENT(OUT) :: total_error INTEGER :: error - INTEGER flag - INTEGER :: free_space_out ! CHARACTER(LEN=10), PARAMETER :: filename = "file_space" diff --git a/fortran/test/tH5G.f90 b/fortran/test/tH5G.f90 index 437970f..e0270a9 100644 --- a/fortran/test/tH5G.f90 +++ b/fortran/test/tH5G.f90 @@ -58,7 +58,6 @@ CHARACTER(LEN=100) :: name !name to put symbolic object CHARACTER(LEN=100) :: commentout !comment to the file INTEGER :: nmembers - INTEGER :: obj_type INTEGER(HSIZE_T), DIMENSION(2) :: data_dims ! ! Create the file. @@ -82,7 +81,6 @@ ! CALL h5gcreate_f(file_id, groupname2, group2_id, error) CALL check("h5gcreate_f",error,total_error) - ! !Create data space for the dataset. ! @@ -135,7 +133,6 @@ ! CALL h5glink_f(file_id, H5G_LINK_SOFT_F, dsetname2, linkname4, error) CALL check("h5glink_f",error,total_error) - ! !close group1 ! @@ -165,8 +162,6 @@ write(*,*) "got nmembers ", nmembers, " is wrong" total_error = total_error +1 end if - - ! !Get the name of a symbolic name ! diff --git a/fortran/test/tH5G_1_8.f90 b/fortran/test/tH5G_1_8.f90 new file mode 100644 index 0000000..4639731 --- /dev/null +++ b/fortran/test/tH5G_1_8.f90 @@ -0,0 +1,2043 @@ +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! 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. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +SUBROUTINE group_test(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + INTEGER(HID_T) :: fapl, fapl2, my_fapl ! /* File access property lists */ + + INTEGER :: 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 + + + CALL mklinks(fapl2, total_error) + CALL cklinks(fapl2, total_error) + + CALL group_info(cleanup, fapl2,total_error) +! CALL ud_hard_links(fapl2,total_error) + CALL timestamps(cleanup, fapl2, total_error) + CALL test_move_preserves(fapl2, total_error) + CALL delete_by_idx(cleanup,fapl2, total_error) + CALL test_lcpl(cleanup, fapl, total_error) + + CALL objcopy(fapl, total_error) + + CALL lifecycle(cleanup, fapl2, 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) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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 :: 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", 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) + 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) + + ! /* 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", 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) + + ! /* 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_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) + + ! /* 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_f2", 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) + CALL check("H5Gget_info_by_idx_f", error, total_error) + ELSE + CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), & + storage_type, nlinks, max_corder, 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_f33", 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_f2", 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) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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 VerifyLogical("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 VerifyLogical("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 VerifyLogical("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 VerifyLogical("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 VerifyLogical("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 VerifyLogical("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) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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 + +! 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) + + !/* 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) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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 + INTEGER(HID_T):: lcpl2_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_LINK_HARD_F - Hard link + ! H5L_LINK_SOFT_F - Soft link + ! H5L_LINK_EXTERNAL_F - External link + ! H5L_LINK_ERROR _F - Error + INTEGER :: address ! If the link is a hard link, address specifies the file address that the link points to + INTEGER(HSIZE_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 VerifyLogical("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) + + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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) :: gid2 !/* Datatype 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 */ + INTEGER :: nmsgs !/* Number of messages in group's header */ + CHARACTER(LEN=NAME_BUF_SIZE) :: objname ! /* Object name */ + CHARACTER(LEN=NAME_BUF_SIZE) :: filename = 'fixx.h5' + INTEGER :: empty_size ! /* Size of an empty file */ + INTEGER :: u ! /* Local index variable */ + 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) + +! USE ISO_C_BINDING + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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' + CHARACTER(LEN=12) :: linkval + +! 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 verifylogical("test_lcpl.H5Lexists", Lexists,.TRUE.,total_error) + + CALL H5Lexists_f(file,"grp1/hard",Lexists, error) + CALL verifylogical("test_lcpl.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) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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=7) :: tmpname ! /* Temporary link 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(HSIZE_T) :: data_size ! Indicates the size, in the number of characters, of the attribute + + INTEGER :: u ! /* Local index variable */ + INTEGER :: Input1, i + INTEGER(HID_T) :: group_id2 + + INTEGER :: iorder ! /* Order within in the index */ + CHARACTER(LEN=2) :: chr2 + INTEGER :: error + ! + ! + ! + CHARACTER(LEN=6) :: filename1 + CHARACTER(LEN=6) :: filename2 + CHARACTER(LEN=80) :: fix_filename1 + CHARACTER(LEN=80) :: fix_filename2 + INTEGER(SIZE_T) :: size_tmp + 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, 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("delete_by_idx.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("delete_by_idx.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), & + f_corder_valid, corder, cset, data_size, error) + + IF(iorder.EQ.H5_ITER_INC_F)THEN + CALL VERIFY("delete_by_idx.H5Lget_info_by_idx_f", corder, u+1, total_error) + ELSE + CALL VERIFY("delete_by_idx.H5Lget_info_by_idx_f", corder, (max_compact - (u + 2)), total_error) + ENDIF + + ! /* 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 verifyString("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) + + USE HDF5 ! This module contains all necessary modules + + 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(HSIZE_T) :: data_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=7) :: tmpval !/* Temporary link value */ + 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), & + f_corder_valid, corder, cset, data_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), & + f_corder_valid, corder, cset, data_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 verifyString("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 verifyString("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 verifyString("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) + + USE HDF5 ! This module contains all necessary modules + + 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_LINK_HARD_F - Hard link + ! H5L_LINK_SOFT_F - Soft link + ! H5L_LINK_EXTERNAL_F - External link + ! H5L_LINK_ERROR _F - Error + INTEGER :: address ! If the link is a hard link, address specifies the file address that the link points to + INTEGER(HSIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value + INTEGER(HSIZE_T) :: data_size ! Indicates the size, in the number of characters, of the attribute + + 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 + +! 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("test_lcpl.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("test_lcpl.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("test_lcpl.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("test_lcpl.h5tcopy_f",error,total_error) + CALL h5tcommit_f(file_id, "/type", type_id, error) + CALL check("test_lcpl.h5tcommit_f", error, total_error) + CALL h5tclose_f(type_id, error) + CALL check("test_lcpl.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("test_lcpl.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("test_lcpl.H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) + + !/* Create a dataspace */ + CALL h5screate_simple_f(2, dims, space_id, error) + CALL check("test_lcpl.h5screate_simple_f",error,total_error) + + ! /* Create a dataset using the default LCPL */ + CALL h5dcreate_f(file_id, "/dataset", H5T_NATIVE_INTEGER, space_id, dset_id, error) + CALL check("test_lcpl.h5dcreate_f", error, total_error) + CALL h5dclose_f(dset_id, error) + CALL check("test_lcpl.h5dclose_f", error, total_error) + + ! Reopen + + CALL H5Dopen_f(file_id, "/dataset", dset_id, error) + CALL check("test_lcpl.h5dopen_f", error, total_error) + + ! /* Extend the dataset */ + CALL H5Dset_extent_f(dset_id, extend_dim, error) + CALL check("test_lcpl.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("test_lcpl.h5sget_simple_extent_dims_f",error, total_error) + + DO i = 1, 2 + tmp1 = dimsout(i) + tmp2 = extend_dim(i) +!EP CALL VERIFY("H5Sget_simple_extent_dims", dimsout(i), extend_dim(i), total_error) + CALL VERIFY("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) +!EP CALL VERIFY("H5Sget_simple_extent_dims", maxdimsout(i), dims(i), total_error) + tmp1 = maxdimsout(i) + tmp2 = dims(i) + CALL VERIFY("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) + ENDDO + + ! /* close data set */ + + CALL h5dclose_f(dset_id, error) + CALL check("test_lcpl.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("test_lcpl.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("test_lcpl.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("test_lcpl.h5Pcreate_f",error,total_error) + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) + CALL check("test_lcpl.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("test_lcpl.test_lcpl.H5Gcreate_f", error, total_error) + CALL H5Gclose_f(group_id, error) + CALL check("test_lcpl.test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.h5tcopy_f",error,total_error) + CALL h5tcommit_f(file_id, "/type2", type_id, error, lcpl_id=lcpl_id) + CALL check("test_lcpl.h5tcommit_f", error, total_error) + CALL h5tclose_f(type_id, error) + CALL check("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.h5dcreate_f", error, total_error) + + CALL h5dclose_f(dset_id, error) + CALL check("test_lcpl.h5dclose_f", error, total_error) + + CALL H5Pget_char_encoding_f(lcpl_id, encoding, error) + CALL check("test_lcpl.H5Pget_char_encoding_f", error, total_error) + CALL VERIFY("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.H5Pclose_f", error, total_error) + + CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) + CALL check("test_lcpl.h5Pcreate_f",error,total_error) + CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) + CALL check("test_lcpl.H5Pset_char_encoding_f",error, total_error) + CALL H5Lcreate_hard_f(file_id, "/dataset2", file_id, "/dataset2_link", error, lcpl_id) + CALL check("test_lcpl.H5Lcreate_hard_f",error, total_error) + + CALL H5Lexists_f(file_id,"/dataset2_link",Lexists, error) + CALL check("test_lcpl.H5Lexists",error, total_error) + CALL verifylogical("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.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("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.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("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! /* H5Lcreate_external */ + + CALL H5Lcreate_external_f("test_lcpl.filename", "path", file_id, "extlink", error, lcpl_id) + CALL check("test_lcpl.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("test_lcpl.H5Lget_info_f", error, total_error) + CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) + + + ! /* Close open IDs */ + + CALL H5Pclose_f(lcpl_id, error) + CALL check("test_lcpl.H5Pclose_f", error, total_error) + CALL H5Sclose_f(space_id, error) + CALL check("test_lcpl.h5Sclose_f",error,total_error) + CALL H5Fclose_f(file_id, error) + CALL check("test_lcpl.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) + + USE HDF5 ! This module contains all necessary modules + + 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) + + USE HDF5 + + 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), sid = (-1), did = (-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(hsize_t), DIMENSION(2) :: dims + 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 VerifyString("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 VerifyString("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 diff --git a/fortran/test/tH5O.f90 b/fortran/test/tH5O.f90 new file mode 100644 index 0000000..7e73104 --- /dev/null +++ b/fortran/test/tH5O.f90 @@ -0,0 +1,446 @@ +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! 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. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +SUBROUTINE test_h5o(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: total_error + + ! /* Output message about test being performed */ + ! WRITE(*,*) "Testing Objects" + +!!$ test_h5o_open(); /* Test generic OPEN FUNCTION */ +!!$ test_h5o_open_by_addr(); /* Test opening objects by address */ +!!$ test_h5o_close(); /* Test generic CLOSE FUNCTION */ +!!$ test_h5o_refcount(); /* Test incrementing and decrementing reference count */ + CALL test_h5o_plist(total_error) ! /* Test object creation properties */ + CALL test_h5o_link(total_error) ! /* Test object link routine */ + +END SUBROUTINE test_h5o + +!/**************************************************************** +!** +!** test_h5o_link: Test creating link to object +!** +!****************************************************************/ + +SUBROUTINE test_h5o_link(total_error) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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) :: mem_space_id, file_space_id, xfer_prp + CHARACTER(LEN=8), PARAMETER :: TEST_FILENAME = 'TestFile' + 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, FALSE = 0 + + LOGICAL :: committed ! /* Whether the named datatype is committed */ + + INTEGER :: i, n, j + INTEGER :: error ! /* Value returned from API calls */ + + ! /* 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) + +!!$ ret = H5Pset_libver_bounds(fapl_id, (new_format ? H5F_LIBVER_LATEST : H5F_LIBVER_EARLIEST), H5F_LIBVER_LATEST); + + ! /* 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 verifyLogical("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) + + CALL h5fclose_f(file_id, error) + CALL check("h5fclose_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) + +END SUBROUTINE test_h5o_link + +!/**************************************************************** +!** +!** test_h5o_plist(): Test object creation properties +!** +!****************************************************************/ + +SUBROUTINE test_h5o_plist(total_error) + + USE HDF5 ! This module contains all necessary modules + + IMPLICIT NONE + INTEGER, INTENT(OUT) :: 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 diff --git a/fortran/test/tH5R.f90 b/fortran/test/tH5R.f90 index 687bb06..adcdfc7 100644 --- a/fortran/test/tH5R.f90 +++ b/fortran/test/tH5R.f90 @@ -17,377 +17,437 @@ ! ! Testing Reference Interface functionality. ! -! The following subroutine tests h5rcreate_f, h5rdereference_f +! The following subroutine tests h5rcreate_f, h5rdereference_f, h5rget_name_f ! and H5Rget_object_type functions ! - SUBROUTINE refobjtest(cleanup, total_error) - USE HDF5 ! This module contains all necessary modules - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: total_error +SUBROUTINE refobjtest(cleanup, total_error) + USE HDF5 ! This module contains all necessary modules + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: 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 + CHARACTER(LEN=4) :: buf_small ! buffer smaller 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) + - 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 - - - ! - !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) + CALL VERIFY("H5Rget_name_f", INT(buf_size),7, total_error) + CALL VerifyString("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 VerifyString("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 VerifyString("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) + USE HDF5 ! This module contains all necessary modules + IMPLICIT NONE + LOGICAL, INTENT(IN) :: cleanup + INTEGER, INTENT(OUT) :: 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(2) :: ref ! Buffers to store references + TYPE(hdset_reg_ref_t_f) , DIMENSION(2) :: ref_out ! + INTEGER(HSIZE_T), DIMENSION(2) :: ref_dim + INTEGER(HSIZE_T), DIMENSION(2) :: data_dims + INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/2,9/) ! Datasets dimensions + INTEGER(HSIZE_T), DIMENSION(1) :: dimsr = (/2/) ! + INTEGER(HSIZE_T), DIMENSION(2) :: start + INTEGER(HSIZE_T), DIMENSION(2) :: count + INTEGER :: rankr = 1 + INTEGER :: rank = 2 + 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 + 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/)) - ! - ! 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) + ! + ! 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 + CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, DATA, data_dims, error) + CALL check("h5dwrite_f", error, 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 + 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) + 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) + 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 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) + ! 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 VerifyString("H5Rget_name_f", buf, "/MATRIX", 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) + ! 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 VerifyString("H5Rget_name_f", TRIM(buf_big), "/MATRIX", total_error) - if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) - CALL check("h5_cleanup_f", error, total_error) - RETURN + ! 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 VerifyString("H5Rget_name_f", TRIM(buf_small), "/MAT", total_error) - END SUBROUTINE refobjtest -! -! The following subroutine tests h5rget_region_f, h5rcreate_f -! and h5rdereference_f functionalities -! - SUBROUTINE refregtest(cleanup, total_error) - USE HDF5 ! This module contains all necessary modules - IMPLICIT NONE - LOGICAL, INTENT(IN) :: cleanup - INTEGER, INTENT(OUT) :: 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) - CHARACTER(LEN=6), PARAMETER :: filename = "Refreg" - CHARACTER(LEN=80) :: fix_filename - CHARACTER(LEN=6), PARAMETER :: dsetnamev = "MATRIX" - CHARACTER(LEN=17), PARAMETER :: dsetnamer = "REGION_REFERENCES" + ! 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 VerifyString("H5Rget_name_f", buf, "/MATRIX", total_error) - 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(2) :: ref ! Buffers to store references - TYPE(hdset_reg_ref_t_f) , DIMENSION(2) :: ref_out ! - INTEGER(HSIZE_T), DIMENSION(2) :: ref_dim - INTEGER(HSIZE_T), DIMENSION(2) :: data_dims - INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/2,9/) ! Datasets dimensions - INTEGER(HSIZE_T), DIMENSION(1) :: dimsr = (/2/) ! - INTEGER(HSIZE_T), DIMENSION(2) :: start - INTEGER(HSIZE_T), DIMENSION(2) :: count - INTEGER :: rankr = 1 - INTEGER :: rank = 2 - 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 - INTEGER :: i, j - 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/)) - ! - ! 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 - CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, data, data_dims, error) - CALL check("h5dwrite_f", error, 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 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) - 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) - 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) - ! - ! 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) - ! - ! 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) + 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 + IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) + CALL check("h5_cleanup_f", error, total_error) + RETURN - END SUBROUTINE refregtest +END SUBROUTINE refregtest diff --git a/fortran/test/tH5Sselect.f90 b/fortran/test/tH5Sselect.f90 index 2f77db9..a004ba7 100644 --- a/fortran/test/tH5Sselect.f90 +++ b/fortran/test/tH5Sselect.f90 @@ -52,10 +52,6 @@ ! INTEGER(HSIZE_T), DIMENSION(3) :: dimsm = (/7,7,3/) - ! - !to get Dataset dimensions - ! - INTEGER(HSIZE_T), DIMENSION(2) :: dims_out ! !Dataset dimensions @@ -103,21 +99,18 @@ ! INTEGER :: memrank = 3 - ! - !integer to get the dataspace rank from dataset - ! - INTEGER :: rank + ! !general purpose integer ! - INTEGER :: i, j, k + INTEGER :: i, j ! !flag to check operation success ! - INTEGER :: error, error_n + INTEGER :: error INTEGER(HSIZE_T), DIMENSION(3) :: data_dims @@ -397,8 +390,7 @@ ! !flag to check operation success ! - INTEGER :: error - LOGICAL :: status + INTEGER :: error INTEGER(HSIZE_T), DIMENSION(3) :: data_dims @@ -720,8 +712,7 @@ 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 + INTEGER(HID_T) :: dataspace ! Dataspace identifier ! !Dataset dimensions @@ -763,10 +754,6 @@ ! INTEGER(HSIZE_T), DIMENSION(RANK, NUMPS) :: coord - ! - !Size of the hyperslab in memory - ! - INTEGER(HSIZE_T), DIMENSION(3) :: count_out = (/3,4,1/) ! !Number of hyperslabs selected in the current dataspace @@ -802,19 +789,9 @@ INTEGER, DIMENSION(5,6) :: data ! - !output buffer - ! - INTEGER, DIMENSION(7,7,3) :: data_out - - ! - !general purpose integer - ! - INTEGER :: i, j, k - - ! !flag to check operation success ! - INTEGER :: error, error_n + INTEGER :: error INTEGER(HSIZE_T), DIMENSION(3) :: data_dims ! diff --git a/fortran/test/tH5T.f90 b/fortran/test/tH5T.f90 index 3bbb974..9901a53 100644 --- a/fortran/test/tH5T.f90 +++ b/fortran/test/tH5T.f90 @@ -27,7 +27,7 @@ ! 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 +! h5tequal_f, h5tinsert_array_f, h5tcommit_f, h5tencode_f, h5tdecode_f USE HDF5 ! This module contains all necessary modules @@ -88,6 +88,12 @@ 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_sid1 + INTEGER(HID_T) :: decoded_tid1 + data_dims(1) = dimsize ! ! Initialize data buffer. @@ -176,7 +182,36 @@ ! 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) + CALL check("h5tinsert_f", error, total_error) + +!!$ !/*----------------------------------------------------------------------- +!!$ ! * 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 VerifyLogical("H5Tequal_f", flag, .TRUE., total_error) ! ! Create the dataset with compound datatype. @@ -485,7 +520,33 @@ endif 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 VerifyLogical("H5Tequal_f", flag, .TRUE., total_error) ! ! Close all open objects. ! diff --git a/fortran/test/tH5VL.f90 b/fortran/test/tH5VL.f90 index 998fef5..13f2af1 100644 --- a/fortran/test/tH5VL.f90 +++ b/fortran/test/tH5VL.f90 @@ -364,7 +364,6 @@ 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 = (/4/) ! Dataset dimensions @@ -374,10 +373,9 @@ CHARACTER(LEN=10), DIMENSION(4) :: string_data ! Array of strings CHARACTER(LEN=10), DIMENSION(4) :: string_data_out ! Data buffers - CHARACTER(LEN=10) :: tmp_str INTEGER :: error ! Error flag - INTEGER :: i, j !general purpose integers + INTEGER :: i !general purpose integers INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/10,4/) INTEGER(HID_T) :: vl_type_id LOGICAL :: vl_flag diff --git a/fortran/test/tH5Z.f90 b/fortran/test/tH5Z.f90 index 2a71961..ea567a2 100644 --- a/fortran/test/tH5Z.f90 +++ b/fortran/test/tH5Z.f90 @@ -22,7 +22,7 @@ IMPLICIT NONE LOGICAL, INTENT(IN) :: cleanup INTEGER, INTENT(OUT) :: total_error - LOGICAL :: status, status1 + LOGICAL :: status INTEGER(HID_T) :: crtpr_id, xfer_id INTEGER :: nfilters INTEGER :: error diff --git a/fortran/test/tf.f90 b/fortran/test/tf.f90 index 673a8e2..1cbac24 100644 --- a/fortran/test/tf.f90 +++ b/fortran/test/tf.f90 @@ -23,30 +23,60 @@ !DEC$attributes dllexport :: check !DEC$endif - SUBROUTINE check(string,error,total_error) - CHARACTER(LEN=*) :: string - INTEGER :: error, total_error - if (error .lt. 0) then - total_error=total_error+1 - write(*,*) string, " failed" - endif - RETURN - END SUBROUTINE check - +SUBROUTINE check(string,error,total_error) + CHARACTER(LEN=*) :: string + INTEGER :: error, total_error + IF (error .LT. 0) THEN + total_error=total_error+1 + WRITE(*,*) string, " FAILED" + ENDIF + RETURN +END SUBROUTINE check !This definition is needed for Windows DLLs !DEC$if defined(BUILD_HDF5_DLL) !DEC$attributes dllexport :: verify !DEC$endif - SUBROUTINE verify(string,value,correct_value,total_error) - CHARACTER(LEN=*) :: string - INTEGER :: value, correct_value, total_error - if (value .ne. correct_value) then - total_error=total_error+1 - write(*,*) string - endif - RETURN - END SUBROUTINE verify +SUBROUTINE VERIFY(string,value,correct_value,total_error) + CHARACTER(LEN=*) :: string + INTEGER :: value, correct_value, total_error + IF (value .NE. correct_value) THEN + total_error=total_error+1 + WRITE(*,*) "ERROR: INCORRECT VALIDATION ", string + ENDIF + RETURN +END SUBROUTINE verify + +!This definition is needed for Windows DLLs +!DEC$if defined(BUILD_HDF5_DLL) +!DEC$attributes dllexport :: verifyLogical +!DEC$endif +SUBROUTINE verifyLogical(string,value,correct_value,total_error) + CHARACTER(LEN=*) :: string + LOGICAL :: value, correct_value + INTEGER :: total_error + IF (value .NEQV. correct_value) THEN + total_error = total_error + 1 + WRITE(*,*) "ERROR: INCORRECT VALIDATION ", string + ENDIF + RETURN +END SUBROUTINE verifyLogical + +!This definition is needed for Windows DLLs +!DEC$if defined(BUILD_HDF5_DLL) +!DEC$attributes dllexport :: verifyString +!DEC$endif +SUBROUTINE verifyString(string, value,correct_value,total_error) + CHARACTER(LEN=*) :: string + CHARACTER(LEN=*) :: value, correct_value + INTEGER :: total_error + IF (TRIM(value) .NE. TRIM(correct_value)) THEN + total_error = total_error + 1 + WRITE(*,*) "ERROR: INCORRECT VALIDATION ", string + ENDIF + RETURN +END SUBROUTINE verifyString + !---------------------------------------------------------------------- ! Name: h5_fixname_f @@ -68,46 +98,46 @@ ! ! !---------------------------------------------------------------------- - SUBROUTINE h5_fixname_f(base_name, full_name, fapl, hdferr) +SUBROUTINE h5_fixname_f(base_name, full_name, fapl, hdferr) ! !This definition is needed for Windows DLLs !DEC$if defined(BUILD_HDF5_DLL) !DEC$attributes dllexport :: h5_fixname_f !DEC$endif - USE H5GLOBAL - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: base_name ! base name - CHARACTER(LEN=*), INTENT(IN) :: full_name ! full name - INTEGER, INTENT(OUT) :: hdferr ! Error code - INTEGER(HID_T), INTENT(IN) :: fapl ! file access property list - - INTEGER(SIZE_T) :: base_namelen ! Length of the base name character string - INTEGER(SIZE_T) :: full_namelen ! Length of the full name character string + USE H5GLOBAL + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: base_name ! base name + CHARACTER(LEN=*), INTENT(IN) :: full_name ! full name + INTEGER, INTENT(OUT) :: hdferr ! Error code + INTEGER(HID_T), INTENT(IN) :: fapl ! file access property list + + INTEGER(SIZE_T) :: base_namelen ! Length of the base name character string + INTEGER(SIZE_T) :: full_namelen ! Length of the full name character string ! INTEGER(HID_T) :: fapl_default - INTERFACE - INTEGER FUNCTION h5_fixname_c(base_name, base_namelen, fapl, & - full_name, full_namelen) - USE H5GLOBAL - !DEC$ IF DEFINED(HDF5F90_WINDOWS) - !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_FIXNAME_C':: h5_fixname_c - !DEC$ ENDIF - !DEC$ATTRIBUTES reference :: base_name - !DEC$ATTRIBUTES reference :: full_name - CHARACTER(LEN=*), INTENT(IN) :: base_name - INTEGER(SIZE_T) :: base_namelen - INTEGER(HID_T), INTENT(IN) :: fapl - CHARACTER(LEN=*), INTENT(IN) :: full_name - INTEGER(SIZE_T) :: full_namelen - END FUNCTION h5_fixname_c - END INTERFACE - - base_namelen = LEN(base_name) - full_namelen = LEN(full_name) - hdferr = h5_fixname_c(base_name, base_namelen, fapl, & - full_name, full_namelen) - - END SUBROUTINE h5_fixname_f + INTERFACE + INTEGER FUNCTION h5_fixname_c(base_name, base_namelen, fapl, & + full_name, full_namelen) + USE H5GLOBAL + !DEC$ IF DEFINED(HDF5F90_WINDOWS) + !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_FIXNAME_C':: h5_fixname_c + !DEC$ ENDIF + !DEC$ATTRIBUTES reference :: base_name + !DEC$ATTRIBUTES reference :: full_name + CHARACTER(LEN=*), INTENT(IN) :: base_name + INTEGER(SIZE_T) :: base_namelen + INTEGER(HID_T), INTENT(IN) :: fapl + CHARACTER(LEN=*), INTENT(IN) :: full_name + INTEGER(SIZE_T) :: full_namelen + END FUNCTION h5_fixname_c + END INTERFACE + + base_namelen = LEN(base_name) + full_namelen = LEN(full_name) + hdferr = h5_fixname_c(base_name, base_namelen, fapl, & + full_name, full_namelen) + +END SUBROUTINE h5_fixname_f !---------------------------------------------------------------------- ! Name: h5_cleanup_f @@ -128,37 +158,37 @@ ! ! !---------------------------------------------------------------------- - SUBROUTINE h5_cleanup_f(base_name, fapl, hdferr) +SUBROUTINE h5_cleanup_f(base_name, fapl, hdferr) ! !This definition is needed for Windows DLLs !DEC$if defined(BUILD_HDF5_DLL) !DEC$attributes dllexport :: h5_cleanup_f !DEC$endif - USE H5GLOBAL - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: base_name ! base name - INTEGER, INTENT(OUT) :: hdferr ! Error code - INTEGER(HID_T), INTENT(IN) :: fapl ! file access property list - - INTEGER(SIZE_T) :: base_namelen ! Length of the base name character string - - INTERFACE - INTEGER FUNCTION h5_cleanup_c(base_name, base_namelen, fapl) - USE H5GLOBAL - !DEC$ IF DEFINED(HDF5F90_WINDOWS) - !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_CLEANUP_C':: h5_cleanup_c - !DEC$ ENDIF - !DEC$ATTRIBUTES reference :: base_name - CHARACTER(LEN=*), INTENT(IN) :: base_name - INTEGER(SIZE_T) :: base_namelen - INTEGER(HID_T), INTENT(IN) :: fapl - END FUNCTION h5_cleanup_c - END INTERFACE - - base_namelen = LEN(base_name) - hdferr = h5_cleanup_c(base_name, base_namelen, fapl) - - END SUBROUTINE h5_cleanup_f + USE H5GLOBAL + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: base_name ! base name + INTEGER, INTENT(OUT) :: hdferr ! Error code + INTEGER(HID_T), INTENT(IN) :: fapl ! file access property list + + INTEGER(SIZE_T) :: base_namelen ! Length of the base name character string + + INTERFACE + INTEGER FUNCTION h5_cleanup_c(base_name, base_namelen, fapl) + USE H5GLOBAL + !DEC$ IF DEFINED(HDF5F90_WINDOWS) + !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_CLEANUP_C':: h5_cleanup_c + !DEC$ ENDIF + !DEC$ATTRIBUTES reference :: base_name + CHARACTER(LEN=*), INTENT(IN) :: base_name + INTEGER(SIZE_T) :: base_namelen + INTEGER(HID_T), INTENT(IN) :: fapl + END FUNCTION h5_cleanup_c + END INTERFACE + + base_namelen = LEN(base_name) + hdferr = h5_cleanup_c(base_name, base_namelen, fapl) + +END SUBROUTINE h5_cleanup_f !---------------------------------------------------------------------- ! Name: h5_exit_f @@ -180,25 +210,25 @@ ! ! !---------------------------------------------------------------------- - SUBROUTINE h5_exit_f(status) +SUBROUTINE h5_exit_f(status) ! !This definition is needed for Windows DLLs !DEC$if defined(BUILD_HDF5_DLL) !DEC$attributes dllexport :: h5_exit_f !DEC$endif - IMPLICIT NONE - INTEGER, INTENT(IN) :: status ! Return code - - INTERFACE - SUBROUTINE h5_exit_c(status) - !DEC$ IF DEFINED(HDF5F90_WINDOWS) - !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_EXIT_C':: h5_exit_c - !DEC$ ENDIF - INTEGER, INTENT(IN) :: status - END SUBROUTINE h5_exit_c - END INTERFACE - - CALL h5_exit_c(status) - - END SUBROUTINE h5_exit_f + IMPLICIT NONE + INTEGER, INTENT(IN) :: status ! Return code + + INTERFACE + SUBROUTINE h5_exit_c(status) + !DEC$ IF DEFINED(HDF5F90_WINDOWS) + !DEC$ ATTRIBUTES C,reference,decorate,alias:'H5_EXIT_C':: h5_exit_c + !DEC$ ENDIF + INTEGER, INTENT(IN) :: status + END SUBROUTINE h5_exit_c + END INTERFACE + + CALL h5_exit_c(status) + +END SUBROUTINE h5_exit_f |