summaryrefslogtreecommitdiffstats
path: root/fortran/test
diff options
context:
space:
mode:
Diffstat (limited to 'fortran/test')
-rw-r--r--fortran/test/Makefile.am14
-rw-r--r--fortran/test/Makefile.in63
-rw-r--r--fortran/test/fflush1.f908
-rw-r--r--fortran/test/fflush2.f9011
-rw-r--r--fortran/test/fortranlib_test_1_8.f90966
-rw-r--r--fortran/test/tH5A.f90111
-rw-r--r--fortran/test/tH5A_1_8.f903777
-rw-r--r--fortran/test/tH5F.f902
-rw-r--r--fortran/test/tH5G.f905
-rw-r--r--fortran/test/tH5G_1_8.f902823
-rw-r--r--fortran/test/tH5O.f90208
-rw-r--r--fortran/test/tH5R.f90768
-rw-r--r--fortran/test/tH5Sselect.f9035
-rw-r--r--fortran/test/tH5T.f9065
-rw-r--r--fortran/test/tH5VL.f904
-rw-r--r--fortran/test/tH5Z.f902
-rw-r--r--fortran/test/tf.f90218
17 files changed, 8486 insertions, 594 deletions
diff --git a/fortran/test/Makefile.am b/fortran/test/Makefile.am
index ed4b9fd..042cfab 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,12 @@ 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 tH5D.f90 tH5R.f90 tH5S.f90 tH5T.f90 tH5VL.f90 tH5Z.f90 \
+ tH5Sselect.f90 tH5O.f90 tH5P.f90 tH5A_1_8.f90 tH5I.f90 tH5G_1_8.f90 tH5E.f90
+
fflush1_SOURCES=fflush1.f90
fflush2_SOURCES=fflush2.f90
diff --git a/fortran/test/Makefile.in b/fortran/test/Makefile.in
index 5e0b92f..3c748e9 100644
--- a/fortran/test/Makefile.in
+++ b/fortran/test/Makefile.in
@@ -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,6 +95,16 @@ 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 $@
+am_fortranlib_test_1_8_OBJECTS = fortranlib_test_1_8.$(OBJEXT) \
+ tH5F.$(OBJEXT) tH5D.$(OBJEXT) tH5R.$(OBJEXT) tH5S.$(OBJEXT) \
+ tH5T.$(OBJEXT) tH5VL.$(OBJEXT) tH5Z.$(OBJEXT) \
+ tH5Sselect.$(OBJEXT) tH5O.$(OBJEXT) tH5P.$(OBJEXT) \
+ tH5A_1_8.$(OBJEXT) tH5I.$(OBJEXT) tH5G_1_8.$(OBJEXT) \
+ tH5E.$(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. -I$(top_builddir)/src@am__isrc@
depcomp = $(SHELL) $(top_srcdir)/bin/depcomp
am__depfiles_maybe = depfiles
@@ -118,9 +125,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)
@@ -368,11 +377,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 +386,11 @@ 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 tH5D.f90 tH5R.f90 tH5S.f90 tH5T.f90 tH5VL.f90 tH5Z.f90 \
+ tH5Sselect.f90 tH5O.f90 tH5P.f90 tH5A_1_8.f90 tH5I.f90 tH5G_1_8.f90 tH5E.f90
fflush1_SOURCES = fflush1.f90
fflush2_SOURCES = fflush2.f90
@@ -469,6 +478,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 +488,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 +511,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 +604,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
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..970f570
--- /dev/null
+++ b/fortran/test/fortranlib_test_1_8.f90
@@ -0,0 +1,966 @@
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! 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 :: mounting_total_error = 0
+ INTEGER :: reopen_total_error = 0
+ INTEGER :: fclose_total_error = 0
+ INTEGER :: fspace_total_error = 0
+ INTEGER :: dataset_total_error = 0
+ INTEGER :: extend_dataset_total_error = 0
+ INTEGER :: refobj_total_error = 0
+ INTEGER :: refreg_total_error = 0
+ INTEGER :: dataspace_total_error = 0
+ INTEGER :: hyperslab_total_error = 0
+ INTEGER :: element_total_error = 0
+ INTEGER :: basic_select_total_error = 0
+ INTEGER :: total_error_compoundtest = 0
+ INTEGER :: basic_datatype_total_error = 0
+ INTEGER :: enum_total_error = 0
+ INTEGER :: external_total_error = 0
+ INTEGER :: multi_file_total_error = 0
+ INTEGER :: attribute_total_error = 0
+ INTEGER :: group_total_error = 0
+ 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(*,*)
+
+ error_string = failure
+ CALL file_space(cleanup, fspace_total_error)
+ IF (fspace_total_error == 0) error_string = success
+ WRITE(*, fmt = '(21a)', advance = 'no') ' File free space test'
+ WRITE(*, fmt = '(49x,a)', advance = 'no') ' '
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + fspace_total_error
+
+ ! write(*,*)
+ ! write(*,*) '========================================='
+ ! write(*,*) 'Testing ATTRIBUTE interface '
+ ! write(*,*) '========================================='
+
+ error_string = failure
+ CALL attribute_test_1_8(cleanup, attribute_total_error)
+ WRITE(*, fmt = '(15a)', advance = 'no') ' ATTRIBUTE TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (attribute_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + attribute_total_error
+
+ CALL group_test(cleanup, group_total_error)
+ WRITE(*, fmt = '(15a)', advance = 'no') ' GROUP TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (group_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + group_total_error
+
+ CALL test_h5o(cleanup, group_total_error )
+ WRITE(*, fmt = '(15a)', advance = 'no') ' H5O TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (group_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + group_total_error
+
+ CALL dtransform(cleanup, group_total_error)
+ WRITE(*, fmt = '(15a)', advance = 'no') ' Dtransform TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (group_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + group_total_error
+
+ CALL test_genprop_basic_class(cleanup, group_total_error)
+ WRITE(*, fmt = '(30a)', advance = 'no') ' test_genprop_basic_class TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (group_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + group_total_error
+ CALL test_h5s_encode(cleanup, group_total_error)
+ WRITE(*, fmt = '(15a)', advance = 'no') ' test_h5s_encode TEST'
+ WRITE(*, fmt = '(55x,a)', advance = 'no') ' '
+ IF (group_total_error == 0) error_string = success
+ WRITE(*, fmt = e_format) error_string
+ total_error = total_error + group_total_error
+
+! CALL test_hard_query(group_total_error)
+
+ total_error = total_error + 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)
+
+!!$
+!!$ ret = H5Sclose(decoded_sid1);
+!!$ CHECK(ret, FAIL, "H5Sclose");
+!!$
+!!$ /*-------------------------------------------------------------------------
+!!$ * Test encoding and decoding of null dataspace.
+!!$ *-------------------------------------------------------------------------
+!!$ */
+!!$ sid2 = H5Screate(H5S_NULL);
+!!$ CHECK(sid2, FAIL, "H5Screate");
+!!$
+!!$ /* Encode null data space in a buffer */
+!!$ ret = H5Sencode(sid2, NULL, &null_size);
+!!$ CHECK(ret, FAIL, "H5Sencode");
+!!$
+!!$ if(null_size>0)
+!!$ null_sbuf = (unsigned char*)HDcalloc((size_t)1, null_size);
+!!$
+!!$ ret = H5Sencode(sid2, null_sbuf, &null_size);
+!!$ CHECK(ret, FAIL, "H5Sencode");
+!!$
+!!$ /* Decode from the dataspace buffer and return an object handle */
+!!$ decoded_sid2=H5Sdecode(null_sbuf);
+!!$ CHECK(decoded_sid2, FAIL, "H5Sdecode");
+!!$
+!!$ /* Verify decoded dataspace */
+!!$ space_type = H5Sget_simple_extent_type(decoded_sid2);
+!!$ VERIFY(space_type, H5S_NULL, "H5Sget_simple_extent_type");
+!!$
+!!$ ret = H5Sclose(sid2);
+!!$ CHECK(ret, FAIL, "H5Sclose");
+!!$
+!!$ ret = H5Sclose(decoded_sid2);
+!!$ CHECK(ret, FAIL, "H5Sclose");
+!!$
+ ! /*-------------------------------------------------------------------------
+ ! * Test encoding and decoding of scalar dataspace.
+ ! *-------------------------------------------------------------------------
+ ! */
+ ! /* Create scalar dataspace */
+
+ CALL H5Screate_f(H5S_SCALAR_F, sid3, error)
+ CALL check("H5Screate_f",error, total_error)
+
+ ! /* Encode scalar data space in a buffer */
+
+ ! First find the buffer size
+ CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
+ CALL check("H5Sencode_f", error, total_error)
+
+ ! encode
+
+ CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
+ CALL check("H5Sencode_f", error, total_error)
+
+
+ ! /* Decode from the dataspace buffer and return an object handle */
+
+ CALL H5Sdecode_f(scalar_buf, decoded_sid3, error)
+ CALL check("H5Sdecode_f", error, total_error)
+
+
+ ! /* Verify extent type */
+
+ CALL H5Sget_simple_extent_type_f(decoded_sid3, space_type, error)
+ CALL check("H5Sget_simple_extent_type_f", error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_type_f", space_type, H5S_SCALAR_F, total_error)
+
+ ! /* Verify decoded dataspace */
+ CALL h5sget_simple_extent_npoints_f(decoded_sid3, n, error)
+ CALL check("h5sget_simple_extent_npoints_f", error, total_error)
+ CALL VERIFY("h5sget_simple_extent_npoints_f", INT(n), 1, total_error)
+
+ CALL H5Sget_simple_extent_ndims_f(decoded_sid3, rank, error)
+ CALL CHECK("H5Sget_simple_extent_ndims_f", error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_ndims_f", rank, 0, total_error )
+
+ CALL h5sclose_f(sid3, error)
+ CALL check("h5sclose_f", error, total_error)
+
+ CALL h5sclose_f(decoded_sid3, error)
+ CALL check("h5sclose_f", error, total_error)
+
+END SUBROUTINE test_h5s_encode
+
+!/*-------------------------------------------------------------------------
+! * Function: test_hard_query
+! *
+! * Purpose: Tests H5Tcompiler_conv() for querying whether a conversion is
+! * a hard one.
+! *
+! * Return: Success: 0
+! *
+! * Failure: number of errors
+! *
+! * Programmer: Raymond Lu
+! * Friday, Sept 2, 2005
+! *
+! * Modifications:
+! *
+! *-------------------------------------------------------------------------
+! */
+
+!!$SUBROUTINE test_hard_query(total_error)
+!!$
+!!$ USE HDF5 ! This module contains all necessary modules
+!!$
+!!$ IMPLICIT NONE
+!!$ INTEGER, INTENT(INOUT) :: total_error
+!!$
+!!$ INTEGER :: error
+!!$ LOGICAL :: flag
+!!$
+!!$ WRITE(*,*) "query functions of compiler conversion"
+!!$
+!!$ ! /* Verify the conversion from int to float is a hard conversion. */
+!!$
+!!$ CALL H5Tcompiler_conv_f(H5T_INTEGER_F, H5T_FLOAT_F, flag, error)
+!!$ CALL check("H5Tcompiler_conv", error, total_error)
+!!$ CALL VerifyLogical("H5Tcompiler_conv", flag, .TRUE.,total_error)
+
+!!$ if((ret = H5Tcompiler_conv(H5T_NATIVE_INT, H5T_NATIVE_FLOAT))!=TRUE) {
+!!$ H5_FAILED();
+!!$ printf("Can't query conversion function\n");
+!!$ goto error;
+!!$ }
+
+!!$ /* Unregister the hard conversion from int to float. Verify the conversion
+!!$ * is a soft conversion. */
+!!$ H5Tunregister(H5T_PERS_HARD, NULL, H5T_NATIVE_INT, H5T_NATIVE_FLOAT, H5T_conv_int_float);
+!!$ if((ret = H5Tcompiler_conv(H5T_NATIVE_INT, H5T_NATIVE_FLOAT))!=FALSE) {
+!!$ H5_FAILED();
+!!$ printf("Can't query conversion function\n");
+!!$ goto error;
+!!$ }
+!!$
+!!$ /* Register the hard conversion from int to float. Verify the conversion
+!!$ * is a hard conversion. */
+!!$ H5Tregister(H5T_PERS_HARD, "int_flt", H5T_NATIVE_INT, H5T_NATIVE_FLOAT, H5T_conv_int_float);
+!!$ if((ret = H5Tcompiler_conv(H5T_NATIVE_INT, H5T_NATIVE_FLOAT))!=TRUE) {
+!!$ H5_FAILED();
+!!$ printf("Can't query conversion function\n");
+!!$ goto error;
+!!$ }
+!!$
+!!$ PASSED();
+!!$ reset_hdf5();
+!!$
+!!$ return 0;
+!!$
+!!$END SUBROUTINE test_hard_query
+
+
+!/*-------------------------------------------------------------------------
+! * Function: test_encode
+! *
+! * Purpose: Tests functions of encoding and decoding datatype.
+! *
+! * Return: Success: 0
+! *
+! * Failure: number of errors
+! *
+! * Programmer: Raymond Lu
+! * July 14, 2004
+! *
+! * Modifications:
+! *
+! *-------------------------------------------------------------------------
+! */
+
+!!$SUBROUTINE test_encode(total_error)
+!!$
+!!$ USE HDF5 ! This module contains all necessary modules
+!!$ struct s1 {
+!!$ int a;
+!!$ float b;
+!!$ long c;
+!!$ double d;
+!!$ };
+!!$ IMPLICIT NONE
+!!$ INTEGER, INTENT(INOUT) :: total_error
+!!$ INTEGER(SIZE_T), PARAMETER :: sizechar = 1024
+!!$ INTEGER :: error
+!!$ INTEGER(hid_t) :: file=-1, tid1=-1, tid2=-1
+!!$ INTEGER(hid_t) :: decoded_tid1=-1, decoded_tid2=-1
+!!$ CHARACTER(LEN=1024) :: filename = 'encode.h5'
+!!$ char compnd_type[]="Compound_type", enum_type[]="Enum_type";
+!!$ short enum_val;
+!!$ size_t cmpd_buf_size = 0;
+!!$ size_t enum_buf_size = 0;
+!!$ unsigned char *cmpd_buf=NULL, *enum_buf=NULL;
+!!$ herr_t ret;
+!!$ INTEGER(HID_T) :: dt5_id ! Memory datatype identifier
+!!$
+!!$ INTEGER(SIZE_T) :: type_sizec ! Size of the character datatype
+!!$
+!!$ WRITE(*,*) "functions of encoding and decoding datatypes"
+!!$
+!!$ !/* Create File */
+!!$
+!!$ CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+!!$ CALL check("H5Fcreate_f", error, total_error)
+!!$
+!!$ !/*-----------------------------------------------------------------------
+!!$ ! * Create compound and enumerate datatypes
+!!$ ! *-----------------------------------------------------------------------
+!!$ ! */
+!!$
+!!$ ! /* Create a compound datatype */
+!!$ CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, error)
+!!$ CALL check("h5tcopy_f", error, total_error)
+!!$ sizechar = 2
+!!$ CALL h5tset_size_f(dt5_id, sizechar, error)
+!!$ CALL check("h5tset_size_f", error, total_error)
+!!$ CALL h5tget_size_f(dt5_id, type_sizec, error)
+!!$ CALL check("h5tget_size_f", error, total_error)
+!!$
+!!$ CALL h5tget_size_f(H5T_NATIVE_INTEGER, type_sizec, error)
+!!$ CALL check("h5tget_size_f", error, total_error)
+!!$ CALL h5tcreate_f(H5T_COMPOUND_F, type_sizec, dtype_id, error)
+!!$
+!!$
+!!$ if((tid1=H5Tcreate(H5T_COMPOUND, sizeof(struct s1))) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't create datatype!\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tinsert(tid1, "a", HOFFSET(struct s1, a), H5T_NATIVE_INT) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field 'a'\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tinsert(tid1, "b", HOFFSET(struct s1, b), H5T_NATIVE_FLOAT) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field 'b'\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tinsert(tid1, "c", HOFFSET(struct s1, c), H5T_NATIVE_LONG) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field 'c'\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tinsert(tid1, "d", HOFFSET(struct s1, d), H5T_NATIVE_DOUBLE) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field 'd'\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Create a enumerate datatype */
+!!$ if((tid2=H5Tcreate(H5T_ENUM, sizeof(short))) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't create enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tenum_insert(tid2, "RED", (enum_val=0,&enum_val)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field into enumeration type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tenum_insert(tid2, "GREEN", (enum_val=1,&enum_val)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field into enumeration type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tenum_insert(tid2, "BLUE", (enum_val=2,&enum_val)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field into enumeration type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tenum_insert(tid2, "ORANGE", (enum_val=3,&enum_val)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field into enumeration type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tenum_insert(tid2, "YELLOW", (enum_val=4,&enum_val)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't insert field into enumeration type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /*-----------------------------------------------------------------------
+!!$ * Test encoding and decoding compound and enumerate datatypes
+!!$ *-----------------------------------------------------------------------
+!!$ */
+!!$ /* Encode compound type in a buffer */
+!!$ if(H5Tencode(tid1, NULL, &cmpd_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode compound type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(cmpd_buf_size>0)
+!!$ cmpd_buf = (unsigned char*)calloc(1, cmpd_buf_size);
+!!$
+!!$ /* Try decoding bogus buffer */
+!!$ H5E_BEGIN_TRY {
+!!$ ret = H5Tdecode(cmpd_buf);
+!!$ } H5E_END_TRY;
+!!$ if(ret!=FAIL) {
+!!$ H5_FAILED();
+!!$ printf("Decoded bogus buffer!\n");
+!!$ goto error;
+!!$ }
+!!$
+!!$ if(H5Tencode(tid1, cmpd_buf, &cmpd_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode compound type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Decode from the compound buffer and return an object handle */
+!!$ if((decoded_tid1 = H5Tdecode(cmpd_buf)) < 0)
+!!$ FAIL_PUTS_ERROR("Can't decode compound type\n")
+!!$
+!!$ /* Verify that the datatype was copied exactly */
+!!$ if(H5Tequal(decoded_tid1, tid1)<=0) {
+!!$ H5_FAILED();
+!!$ printf("Datatype wasn't encoded & decoded identically\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Query member number and member index by name, for compound type. */
+!!$ if(H5Tget_nmembers(decoded_tid1)!=4) {
+!!$ H5_FAILED();
+!!$ printf("Can't get member number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tget_member_index(decoded_tid1, "c")!=2) {
+!!$ H5_FAILED();
+!!$ printf("Can't get correct index number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$
+!!$ /* Encode enumerate type in a buffer */
+!!$ if(H5Tencode(tid2, NULL, &enum_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(enum_buf_size>0)
+!!$ enum_buf = (unsigned char*)calloc(1, enum_buf_size);
+!!$
+!!$ if(H5Tencode(tid2, enum_buf, &enum_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Decode from the enumerate buffer and return an object handle */
+!!$ if((decoded_tid2=H5Tdecode(enum_buf)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't decode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Verify that the datatype was copied exactly */
+!!$ if(H5Tequal(decoded_tid2, tid2)<=0) {
+!!$ H5_FAILED();
+!!$ printf("Datatype wasn't encoded & decoded identically\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Query member number and member index by name, for enumeration type. */
+!!$ if(H5Tget_nmembers(decoded_tid2)!=5) {
+!!$ H5_FAILED();
+!!$ printf("Can't get member number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tget_member_index(decoded_tid2, "ORANGE") != 3) {
+!!$ H5_FAILED();
+!!$ printf("Can't get correct index number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /*-----------------------------------------------------------------------
+!!$ * Commit and reopen the compound and enumerate datatypes
+!!$ *-----------------------------------------------------------------------
+!!$ */
+!!$ /* Commit compound datatype and close it */
+!!$ if(H5Tcommit2(file, compnd_type, tid1, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't commit compound datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(tid1) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(decoded_tid1) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ free(cmpd_buf);
+!!$ cmpd_buf_size = 0;
+!!$
+!!$ /* Commit enumeration datatype and close it */
+!!$ if(H5Tcommit2(file, enum_type, tid2, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't commit compound datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(tid2) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(decoded_tid2) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ free(enum_buf);
+!!$ enum_buf_size = 0;
+!!$
+!!$ /* Open the dataytpe for query */
+!!$ if((tid1 = H5Topen2(file, compnd_type, H5P_DEFAULT)) < 0)
+!!$ FAIL_STACK_ERROR
+!!$ if((tid2 = H5Topen2(file, enum_type, H5P_DEFAULT)) < 0)
+!!$ FAIL_STACK_ERROR
+!!$
+!!$
+!!$ /* Encode compound type in a buffer */
+!!$ if(H5Tencode(tid1, NULL, &cmpd_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode compound type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(cmpd_buf_size>0)
+!!$ cmpd_buf = (unsigned char*)calloc(1, cmpd_buf_size);
+!!$
+!!$ if(H5Tencode(tid1, cmpd_buf, &cmpd_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode compound type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Decode from the compound buffer and return an object handle */
+!!$ if((decoded_tid1 = H5Tdecode(cmpd_buf)) < 0)
+!!$ FAIL_PUTS_ERROR("Can't decode compound type\n")
+!!$
+!!$ /* Verify that the datatype was copied exactly */
+!!$ if(H5Tequal(decoded_tid1, tid1)<=0) {
+!!$ H5_FAILED();
+!!$ printf("Datatype wasn't encoded & decoded identically\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Query member number and member index by name, for compound type. */
+!!$ if(H5Tget_nmembers(decoded_tid1)!=4) {
+!!$ H5_FAILED();
+!!$ printf("Can't get member number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tget_member_index(decoded_tid1, "c")!=2) {
+!!$ H5_FAILED();
+!!$ printf("Can't get correct index number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /*-----------------------------------------------------------------------
+!!$ * Test encoding and decoding compound and enumerate datatypes
+!!$ *-----------------------------------------------------------------------
+!!$ */
+!!$ /* Encode enumerate type in a buffer */
+!!$ if(H5Tencode(tid2, NULL, &enum_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(enum_buf_size>0)
+!!$ enum_buf = (unsigned char*)calloc(1, enum_buf_size);
+!!$
+!!$ if(H5Tencode(tid2, enum_buf, &enum_buf_size) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't encode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Decode from the enumerate buffer and return an object handle */
+!!$ if((decoded_tid2=H5Tdecode(enum_buf)) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't decode enumerate type\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Verify that the datatype was copied exactly */
+!!$ if(H5Tequal(decoded_tid2, tid2)<=0) {
+!!$ H5_FAILED();
+!!$ printf("Datatype wasn't encoded & decoded identically\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Query member number and member index by name, for enumeration type. */
+!!$ if(H5Tget_nmembers(decoded_tid2)!=5) {
+!!$ H5_FAILED();
+!!$ printf("Can't get member number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tget_member_index(decoded_tid2, "ORANGE")!=3) {
+!!$ H5_FAILED();
+!!$ printf("Can't get correct index number\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /*-----------------------------------------------------------------------
+!!$ * Close and release
+!!$ *-----------------------------------------------------------------------
+!!$ */
+!!$ /* Close datatype and file */
+!!$ if(H5Tclose(tid1) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(tid2) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(H5Tclose(decoded_tid1) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$ if(H5Tclose(decoded_tid2) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close datatype\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ if(H5Fclose(file) < 0) {
+!!$ H5_FAILED();
+!!$ printf("Can't close file\n");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ free(cmpd_buf);
+!!$ free(enum_buf);
+!!$
+!!$ PASSED();
+!!$ return 0;
+!!$
+!!$ error:
+!!$ H5E_BEGIN_TRY {
+!!$ H5Tclose (tid1);
+!!$ H5Tclose (tid2);
+!!$ H5Tclose (decoded_tid1);
+!!$ H5Tclose (decoded_tid2);
+!!$ H5Fclose (file);
+!!$ } H5E_END_TRY;
+!!$ return 1;
+!!$}
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..bba0340
--- /dev/null
+++ b/fortran/test/tH5A_1_8.f90
@@ -0,0 +1,3777 @@
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! 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
+!!$
+!!$! - - - local declarations - - -
+!!$
+!!$ INTEGER :: max_compact,min_dense,curr_dset,u
+!!$ CHARACTER (LEN=NAME_BUF_SIZE) :: attrname
+!!$
+ 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
+
+!!$ INTEGER :: sid
+!!$ INTEGER :: attr
+!!$ INTEGER :: dcpl
+!!$ INTEGER ::is_empty
+!!$ INTEGER ::is_dense
+!!$
+ 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)
+! ret = H5Pset_attr_creation_order(dcpl, (H5P_CRT_ORDER_TRACKED | H5P_CRT_ORDER_INDEXED));
+
+ ! /* 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)
+
+! FIX: need to check optional parameters i.e. h5dcreate1/2_f
+
+ 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)
+
+!!$ dset1 = H5Dcreate2(fid, DSET1_NAME, H5T_NATIVE_UCHAR, sid, H5P_DEFAULT, dcpl, H5P_DEFAULT)
+!!$ dset2 = H5Dcreate2(fid, DSET2_NAME, H5T_NATIVE_UCHAR, sid, H5P_DEFAULT, dcpl, H5P_DEFAULT)
+!!$ dset3 = H5Dcreate2(fid, DSET3_NAME, H5T_NATIVE_UCHAR, sid, H5P_DEFAULT, dcpl, H5P_DEFAULT)
+
+ 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
+
+ ! 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)
+ 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)
+
+!!$ fid = H5Fopen(FILENAME, H5F_ACC_RDWR, fapl)
+!!$ CALL CHECK(fid, FAIL, "H5Fopen")
+
+ 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)
+! --------------------------------------------------
+ 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 .MSB.
+
+ 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
+
+! CHARACTER (LEN=NAME_BUF_SIZE) :: attrname
+
+! /* 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)
+
+!!$ empty_filesize = h5_get_file_size(FILENAME)
+!!$ IF (empty_filesize < 0) CALL TestErrPrintf("Line %d: file size wrong!\n"C, __LINE__)
+ ! /* 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)
+!!$ dataset = H5Dcreate2(fid, DSET1_NAME, H5T_NATIVE_UCHAR, sid, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)
+!!$ CALL CHECK(dataset, FAIL, "H5Dcreate2")
+ ! /* 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)
+
+!!$ CALL HDstrcpy(attrname, "null attr")
+!!$ attr = H5Acreate2(dataset, attrname, H5T_NATIVE_UINT, null_sid, H5P_DEFAULT, H5P_DEFAULT)
+ ! /* 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 VERIFY("h5aget_info_f",INT(data_size),INT(storage_size),total_error)
+
+
+ CALL h5aclose_f(attr,error)
+ CALL check("h5aclose_f",error,total_error)
+
+
+!!$ CALL HDstrcpy(attrname, "null attr #2")
+!!$ attr = H5Acreate2(dataset, attrname, H5T_NATIVE_UINT, null_sid, H5P_DEFAULT, H5P_DEFAULT)
+!!$ CALL CHECK(attr, FAIL, "H5Acreate2")
+!!$ value = 23
+!!$ ret = H5Awrite(attr, H5T_NATIVE_UINT, value)
+!!$ CALL CHECK(ret, FAIL, "H5Awrite")
+!!$ CALL VERIFY(value, 23, "H5Awrite")
+!!$ ret = H5Aclose(attr)
+!!$ CALL CHECK(ret, FAIL, "H5Aclose")
+!!$ ret = H5Dclose(dataset)
+!!$ CALL CHECK(ret, FAIL, "H5Dclose")
+!!$ ret = H5Fclose(fid)
+!!$ CALL CHECK(ret, FAIL, "H5Fclose")
+!!$ fid = H5Fopen(FILENAME, H5F_ACC_RDWR, fapl)
+!!$ CALL CHECK(fid, FAIL, "H5Fopen")
+!!$ dataset = H5Dopen2(fid, DSET1_NAME, H5P_DEFAULT)
+!!$ CALL CHECK(dataset, FAIL, "H5Dopen2")
+!!$ CALL HDstrcpy(attrname, "null attr #2")
+!!$ attr = H5Aopen(dataset, attrname, H5P_DEFAULT)
+!!$ CALL CHECK(attr, FAIL, "H5Aopen")
+!!$ value = 23
+!!$ ret = H5Aread(attr, H5T_NATIVE_UINT, value)
+!!$ CALL CHECK(ret, FAIL, "H5Aread")
+!!$ CALL VERIFY(value, 23, "H5Aread")
+!!$ attr_sid = H5Aget_space(attr)
+!!$ CALL CHECK(attr_sid, FAIL, "H5Aget_space")
+!!$ cmp = H5Sextent_equal(attr_sid, null_sid)
+!!$ CALL CHECK(cmp, FAIL, "H5Sextent_equal")
+!!$ CALL VERIFY(cmp, TRUE, "H5Sextent_equal")
+
+
+ CALL H5Sclose_f(attr_sid, error)
+ CALL check("H5Sclose_f",error,total_error)
+
+
+!!$ ret = H5Sclose(attr_sid)
+!!$ CALL CHECK(ret, FAIL, "H5Sclose")
+!!$ storage_size = H5Aget_storage_size(attr)
+!!$ CALL VERIFY(storage_size, 0, "H5Aget_storage_size")
+!!$ ret = H5Aget_info(attr, ainfo)
+!!$ CALL CHECK(ret, FAIL, "H5Aget_info")
+!!$ CALL VERIFY(ainfo%data_size, storage_size, "H5Aget_info")
+!!$ ret = H5Aclose(attr)
+!!$ CALL CHECK(ret, FAIL, "H5Aclose")
+!!$ CALL HDstrcpy(attrname, "null attr")
+!!$ attr = H5Aopen(dataset, attrname, H5P_DEFAULT)
+!!$ CALL CHECK(attr, FAIL, "H5Aopen")
+!!$ value = 23
+!!$ ret = H5Awrite(attr, H5T_NATIVE_UINT, value)
+!!$ CALL CHECK(ret, FAIL, "H5Awrite")
+!!$ CALL VERIFY(value, 23, "H5Awrite")
+
+
+!!$ CALL H5Aclose_f(attr, error)
+!!$ CALL check("H5Aclose_f", error,total_error)
+!!$ CALL H5Ddelete_f(fid, DSET1_NAME, H5P_DEFAULT_F, error)
+!!$ CALL check("H5Aclose_f", error,total_error)
+
+ CALL H5Dclose_f(dataset, error)
+ CALL check("H5Dclose_f", error,total_error)
+
+!!$ ret = H5delete(fid, DSET1_NAME, H5P_DEFAULT)
+!!$ CALL CHECK(ret, FAIL, "H5Ldelete")
+
+! TESTING1
+
+ 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)
+
+!!$ filesize = h5_get_file_size(FILENAME)
+!!$ CALL VERIFY(filesize, empty_filesize, "h5_get_file_size")
+
+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)
+
+ ! CHECK(ret, FAIL, "attr_open_check");
+ 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
+! CASE DEFAULT
+! CALL HDassert(0.AND."Toomanydatasets!")
+ 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
+
+ data_dims = 0
+!!$ htri_t is_empty; /* Are there any attributes? */
+!!$ htri_t is_dense; /* Are attributes stored densely? */
+!!$ hsize_t nattrs; /* Number of attributes on object */
+!!$ hsize_t name_count; /* # of records in name index */
+!!$ hsize_t corder_count; /* # of records in creation order index */
+!!$ hbool_t use_index; /* Use index on creation order values */
+!!$ char attrname[NAME_BUF_SIZE]; /* Name of attribute */
+!!$ char tmpname[NAME_BUF_SIZE]; /* Temporary attribute name */
+!!$ unsigned curr_dset; /* Current dataset to work on */
+!!$ unsigned u; /* Local index variable */
+!!$ herr_t ret; /* Generic return value */
+
+ ! /* 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
+ 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,-1,total_error)
+
+ size = 0
+ CALL h5aget_name_by_idx_f(my_dataset, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, &
+ 0_HSIZE_T, tmpname, size, error, lapl_id=H5P_DEFAULT_F)
+ CALL VERIFY("h5aget_name_by_idx_f",error,-1,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 */
+
+ CALL attr_info_by_idx_check(my_dataset, attrname, INT(j,HSIZE_T), use_index(i), total_error )
+
+ CALL check("attr_info_by_idx_check",error,total_error)
+
+ !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, "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 offset queries */
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_INC, (hsize_t)u, &ainfo, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_info_by_idx");
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, (hsize_t)u, &ainfo, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_info_by_idx");
+!!$ ret = H5Aget_name_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_INC, (hsize_t)u, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_name_by_idx");
+!!$
+!!$ /* Create more attributes, to push into dense form */
+!!$ for(; u < (max_compact * 2); u++) {
+!!$ /* Create attribute */
+!!$ sprintf(attrname, "attr %02u", u);
+!!$ attr = H5Acreate2(my_dataset, attrname, H5T_NATIVE_UINT, sid, H5P_DEFAULT, H5P_DEFAULT);
+!!$ CHECK(attr, FAIL, "H5Acreate2");
+!!$
+!!$ /* Write data into the attribute */
+!!$ ret = H5Awrite(attr, H5T_NATIVE_UINT, &u);
+!!$ CHECK(ret, FAIL, "H5Awrite");
+!!$
+!!$ /* Close attribute */
+!!$ ret = H5Aclose(attr);
+!!$ CHECK(ret, FAIL, "H5Aclose");
+!!$
+!!$ /* Verify state of object */
+!!$ is_dense = H5O_is_attr_dense_test(my_dataset);
+!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test");
+!!$
+!!$ /* 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");
+!!$ } /* end for */
+!!$
+!!$ /* 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 */
+!!$
+!!$ /* Check for out of bound offset queries */
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_INC, (hsize_t)u, &ainfo, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_info_by_idx");
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, (hsize_t)u, &ainfo, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_info_by_idx");
+!!$ ret = H5Aget_name_by_idx(my_dataset, ".", H5_INDEX_CRT_ORDER, H5_ITER_INC, (hsize_t)u, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Aget_name_by_idx");
+!!$ } /* end for */
+!!$
+
+!!$ } /* end for */
+!!$
+
+ 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 :: 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 :: const
+!!$ INTEGER :: har
+!!$ INTEGER :: attrname
+!!$ INTEGER :: hsize_t
+!!$ INTEGER :: hbool_t
+!!$ INTEGER :: se_index
+!!$ INTEGER :: old_nerrs
+!!$ CHARACTER (LEN=NAME_BUF_SIZE) :: tmpname
+!!$ ainfo
+!!$ ret
+!!$ old_nerrs = GetTestNumErrs()
+
+ ! /* 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, 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,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 */
+
+!!$ CALL HDmemset(tmpname, 0, (size_t))
+
+ CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, &
+ n, tmpname, NAME_BUF_SIZE, error)
+ CALL check("h5aget_name_by_idx_f",error,total_error)
+
+ IF(TRIM(attrname).NE.TRIM(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
+ ! CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+ ! /* 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, 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,0,total_error)
+
+ ! CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+
+ ! /* 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 HDmemset(tmpname, 0, (size_t))
+ CALL h5aget_name_by_idx_f(obj_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, &
+ n, tmpname, NAME_BUF_SIZE, error)
+ 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)
+
+ ! CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+ 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)
+!!$ CALL HDmemset(tmpname, 0, (size_t))
+!!$ ret = H5Aget_name_by_idx(obj_id, ".", H5_INDEX_CRT_ORDER, 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__)
+!!$ CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+ CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_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,0,total_error)
+!!$ CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+ CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_INC_F, n, &
+ f_corder_valid, corder, cset, data_size, error)
+ CALL check("h5aget_info_by_idx_f",error,total_error)
+ CALL VERIFY("h5aget_info_by_idx_f",corder,INT(n),total_error)
+!!$ CALL HDmemset(tmpname, 0, (size_t))
+!!$ 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 HDmemset(ainfo, 0, SIZEOF(ainfo)
+ 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)
+!!$ CALL HDmemset(ainfo, 0, SIZEOF(ainfo)
+ CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_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)
+!!$ CALL HDmemset(tmpname, 0, (size_t))
+!!$ 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 */
+!!$ CALL HDmemset(big_value, 1, SIZEOF(big_value)
+
+ ! /* 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)
+!!$
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_nindexes");
+!!$
+ ! /* Make attributes > 500 bytes shared */
+ CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error)
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_index");
+!!$
+ ! /* 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)
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_index");
+ 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)
+
+!!$
+!!$ /* Get size of file */
+!!$ empty_filesize = h5_get_file_size(FILENAME);
+!!$ if(empty_filesize < 0)
+!!$ TestErrPrintf("Line %d: file size wrong!\n", __LINE__);
+
+ ! /* 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, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F,error)
+ 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, -1)
+!!$ 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
+ 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
+ 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
+ INTEGER :: Input1
+
+ data_dims = 0
+
+!!$test_attr_delete_by_idx(hbool_t new_format, hid_t fcpl, hid_t fapl)
+!!${
+!!$ hid_t fid; /* HDF5 File ID */
+!!$ hid_t dset1, dset2, dset3; /* Dataset IDs */
+!!$ hid_t my_dataset; /* Current dataset ID */
+!!$ hid_t sid; /* Dataspace ID */
+!!$ hid_t attr; /* Attribute ID */
+!!$ hid_t dcpl; /* Dataset creation property list ID */
+!!$ H5A_info_t ainfo; /* Attribute information */
+!!$ unsigned max_compact; /* Maximum # of links to store in group compactly */
+!!$ unsigned min_dense; /* Minimum # of links to store in group "densely" */
+!!$ htri_t is_empty; /* Are there any attributes? */
+!!$ htri_t is_dense; /* Are attributes stored densely? */
+!!$ hsize_t nattrs; /* Number of attributes on object */
+!!$ hsize_t name_count; /* # of records in name index */
+!!$ hsize_t corder_count; /* # of records in creation order index */
+!!$ H5_index_t idx_type; /* Type of index to operate on */
+!!$ H5_iter_order_t order; /* Order within in the index */
+!!$ hbool_t use_index; /* Use index on creation order values */
+!!$ char attrname[NAME_BUF_SIZE]; /* Name of attribute */
+!!$ char tmpname[NAME_BUF_SIZE]; /* Temporary attribute name */
+!!$ unsigned curr_dset; /* Current dataset to work on */
+!!$ unsigned u; /* Local index variable */
+!!$ herr_t ret; /* Generic return value */
+!!$
+
+ ! /* 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 */
+ CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, 0_HSIZE_T,error, lapl_id=H5P_DEFAULT_F)
+ CALL VERIFY("H5Adelete_by_idx_f",error,-1,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,-1,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 */
+
+
+ CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, 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));
+
+ CALL h5aget_info_by_idx_f(my_dataset, ".", idx_type, order, 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-(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, size, error, lapl_id=H5P_DEFAULT_F)
+ 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 */
+
+ CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, 0_HSIZE_T, 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,-1,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 */
+!!$ HDmemset(&ainfo, 0, sizeof(ainfo));
+
+
+ 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, size, 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 * 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,-1,total_error)
+ ENDDO
+
+
+!!$
+!!$
+!!$ /* Delete attributes in middle */
+!!$
+!!$
+!!$ /* Work on all the datasets */
+!!$ for(curr_dset = 0; curr_dset < NUM_DSETS; curr_dset++) {
+!!$ switch(curr_dset) {
+!!$ case 0:
+!!$ my_dataset = dset1;
+!!$ break;
+!!$
+!!$ case 1:
+!!$ my_dataset = dset2;
+!!$ break;
+!!$
+!!$ case 2:
+!!$ my_dataset = dset3;
+!!$ break;
+!!$
+!!$ default:
+!!$ HDassert(0 && "Too many datasets!");
+!!$ } /* end switch */
+!!$
+!!$ /* Create attributes, to push into dense form */
+!!$ for(u = 0; u < (max_compact * 2); u++) {
+!!$ /* Create attribute */
+!!$ sprintf(attrname, "attr %02u", u);
+!!$ attr = H5Acreate2(my_dataset, attrname, H5T_NATIVE_UINT, sid, H5P_DEFAULT, H5P_DEFAULT);
+!!$ CHECK(attr, FAIL, "H5Acreate2");
+!!$
+!!$ /* Write data into the attribute */
+!!$ ret = H5Awrite(attr, H5T_NATIVE_UINT, &u);
+!!$ CHECK(ret, FAIL, "H5Awrite");
+!!$
+!!$ /* Close attribute */
+!!$ ret = H5Aclose(attr);
+!!$ CHECK(ret, FAIL, "H5Aclose");
+!!$
+!!$ /* 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");
+!!$ } /* end for */
+!!$ } /* end for */
+!!$
+!!$ /* Work on all the datasets */
+!!$ for(curr_dset = 0; curr_dset < NUM_DSETS; curr_dset++) {
+!!$ switch(curr_dset) {
+!!$ case 0:
+!!$ my_dataset = dset1;
+!!$ break;
+!!$
+!!$ case 1:
+!!$ my_dataset = dset2;
+!!$ break;
+!!$
+!!$ case 2:
+!!$ my_dataset = dset3;
+!!$ break;
+!!$
+!!$ default:
+!!$ HDassert(0 && "Too many datasets!");
+!!$ } /* end switch */
+!!$
+!!$ /* Delete every other attribute from dense storage, in appropriate order */
+!!$ for(u = 0; u < max_compact; u++) {
+!!$ /* Delete attribute */
+!!$ ret = H5Adelete_by_idx(my_dataset, ".", idx_type, order, (hsize_t)u, H5P_DEFAULT);
+!!$ CHECK(ret, FAIL, "H5Adelete_by_idx");
+!!$
+!!$ /* Verify the attribute information for first attribute in appropriate order */
+!!$ HDmemset(&ainfo, 0, sizeof(ainfo));
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", idx_type, order, (hsize_t)u, &ainfo, H5P_DEFAULT);
+!!$ if(new_format) {
+!!$ if(order == H5_ITER_INC) {
+!!$ VERIFY(ainfo.corder, ((u * 2) + 1), "H5Aget_info_by_idx");
+!!$ } /* end if */
+!!$ else {
+!!$ VERIFY(ainfo.corder, ((max_compact * 2) - ((u * 2) + 2)), "H5Aget_info_by_idx");
+!!$ } /* end else */
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for first attribute in appropriate order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ ret = H5Aget_name_by_idx(my_dataset, ".", idx_type, order, (hsize_t)u, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT);
+!!$ if(order == H5_ITER_INC)
+!!$ sprintf(attrname, "attr %02u", ((u * 2) + 1));
+!!$ else
+!!$ sprintf(attrname, "attr %02u", ((max_compact * 2) - ((u * 2) + 2)));
+!!$ ret = HDstrcmp(attrname, tmpname);
+!!$ VERIFY(ret, 0, "H5Aget_name_by_idx");
+!!$ } /* end for */
+!!$ } /* end for */
+!!$
+!!$ /* Work on all the datasets */
+!!$ for(curr_dset = 0; curr_dset < NUM_DSETS; curr_dset++) {
+!!$ switch(curr_dset) {
+!!$ case 0:
+!!$ my_dataset = dset1;
+!!$ break;
+!!$
+!!$ case 1:
+!!$ my_dataset = dset2;
+!!$ break;
+!!$
+!!$ case 2:
+!!$ my_dataset = dset3;
+!!$ break;
+!!$
+!!$ default:
+!!$ HDassert(0 && "Too many datasets!");
+!!$ } /* end switch */
+!!$
+!!$ /* Delete remaining attributes from dense storage, in appropriate order */
+!!$ for(u = 0; u < (max_compact - 1); u++) {
+!!$ /* Delete attribute */
+!!$ ret = H5Adelete_by_idx(my_dataset, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT);
+!!$ CHECK(ret, FAIL, "H5Adelete_by_idx");
+!!$
+!!$ /* Verify the attribute information for first attribute in appropriate order */
+!!$ HDmemset(&ainfo, 0, sizeof(ainfo));
+!!$ ret = H5Aget_info_by_idx(my_dataset, ".", idx_type, order, (hsize_t)0, &ainfo, H5P_DEFAULT);
+!!$ if(new_format) {
+!!$ if(order == H5_ITER_INC) {
+!!$ VERIFY(ainfo.corder, ((u * 2) + 3), "H5Aget_info_by_idx");
+!!$ } /* end if */
+!!$ else {
+!!$ VERIFY(ainfo.corder, ((max_compact * 2) - ((u * 2) + 4)), "H5Aget_info_by_idx");
+!!$ } /* end else */
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for first attribute in appropriate order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ ret = H5Aget_name_by_idx(my_dataset, ".", idx_type, order, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT);
+!!$ if(order == H5_ITER_INC)
+!!$ sprintf(attrname, "attr %02u", ((u * 2) + 3));
+!!$ else
+!!$ sprintf(attrname, "attr %02u", ((max_compact * 2) - ((u * 2) + 4)));
+!!$ ret = HDstrcmp(attrname, tmpname);
+!!$ VERIFY(ret, 0, "H5Aget_name_by_idx");
+!!$ } /* end for */
+!!$
+!!$ /* Delete last attribute */
+!!$ ret = H5Adelete_by_idx(my_dataset, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT);
+!!$ CHECK(ret, FAIL, "H5Adelete_by_idx");
+!!$
+!!$ /* 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 */
+!!$ ret = H5Adelete_by_idx(my_dataset, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Adelete_by_idx");
+!!$ } /* end for */
+
+ ! /* 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 */
+!!$ HDmemset(big_value, 1, sizeof(big_value));
+!!$
+ ! /* 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)
+!!$
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_nindexes");
+!!$
+ ! /* Make attributes > 500 bytes shared */
+ CALL H5Pset_shared_mesg_index_f(my_fcpl, 0, H5O_SHMESG_ATTR_FLAG_F, 500,error)
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_index");
+!!$
+ ! /* 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)
+!!$ CHECK_I(ret, "H5Pset_shared_mesg_index");
+ 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)
+!!$
+!!$ /* Get size of file */
+!!$ empty_filesize = h5_get_file_size(FILENAME);
+!!$ if(empty_filesize < 0)
+!!$ TestErrPrintf("Line %d: file size wrong!\n", __LINE__);
+
+ ! /* 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, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F,error)
+ 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)
+
+
+ ! /* Get size of file */
+!!$ empty_filesize = h5_get_file_size(FILENAME);
+!!$ if(empty_filesize < 0)
+!!$ TestErrPrintf("Line %d: file size wrong!\n", __LINE__);
+
+ ! /* 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
+
+! size_t name_len; /* Length of attribute name */
+! char check_name[ATTR_NAME_LEN]; /* Buffer for checking attribute names */
+
+ ! /* 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
+
+ ! /* 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 , -1, 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)
+
+ ! /* Check on dataset's attribute storage status */
+!!$ is_empty = H5O_is_attr_empty_test(dataset);
+!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test");
+!!$ is_dense = H5O_is_attr_dense_test(dataset);
+!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test");
+
+ ! /* 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)
+
+ ! /* Check on dataset's attribute storage status */
+!!$ is_empty = H5O_is_attr_empty_test(dataset);
+!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test");
+!!$ is_dense = H5O_is_attr_dense_test(dataset);
+!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test");
+
+ ! /* 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 = 3
+ INTEGER, PARAMETER :: NX = 20
+ INTEGER, PARAMETER :: NY = 5
+ INTEGER, PARAMETER :: NZ = 10
+! INTEGER(HSIZE_T), DIMENSION(3) :: dims1 = (/NX,NY,NZ/)
+
+ 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"
+! int attr_data1a[ATTR1_DIM1]={256,11945,-22107};
+ 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 :: attr_data1
+ INTEGER(HSIZE_T), DIMENSION(2) :: dims2 = (/4,6/) ! Dataset dimensions
+
+!!!! start
+ 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
+
+ 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 h5screate_simple_f(SPACE1_RANK, dims1, sid1, error)
+ CALL check("h5screate_simple_f",error,total_error)
+
+ ! /* Create a dataset */
+! sid1 = H5Screate_simple(SPACE1_RANK, dims1, NULL);
+ 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, dims2, 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 */
+ data_dims(1) = 3
+
+ CALL h5awrite_f(attr, H5T_NATIVE_INTEGER, attr_data1, data_dims, 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, data_dims, 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)
+ 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, data_dims, 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)
+!!$
+!!$ /* Open the second attribute again */
+!!$ attr2=H5Aopen(dataset, ATTR1A_NAME, H5P_DEFAULT);
+!!$ CHECK(attr, FAIL, "H5Aopen");
+!!$
+!!$ /* Verify new attribute name */
+!!$ attr_name_size = H5Aget_name(attr2, (size_t)0, NULL);
+!!$ CHECK(attr_name_size, FAIL, "H5Aget_name");
+!!$
+!!$ if(attr_name_size>0)
+!!$ attr_name = (char*)HDcalloc((size_t)(attr_name_size+1), sizeof(char));
+!!$
+!!$ ret=(herr_t)H5Aget_name(attr2, (size_t)(attr_name_size+1), attr_name);
+!!$ CHECK(ret, FAIL, "H5Aget_name");
+!!$ ret=HDstrcmp(attr_name, ATTR1A_NAME);
+!!$ VERIFY(ret, 0, "HDstrcmp");
+!!$
+!!$ if(attr_name)
+!!$ HDfree(attr_name);
+!!$
+!!$ /* Read attribute information immediately, without closing attribute */
+!!$ ret=H5Aread(attr2,H5T_NATIVE_INT,read_data1);
+!!$ CHECK(ret, FAIL, "H5Aread");
+!!$
+!!$ /* Verify values read in */
+!!$ for(i=0; i<ATTR1_DIM1; i++)
+!!$ if(attr_data1a[i]!=read_data1[i])
+!!$ TestErrPrintf("%d: attribute data different: attr_data1a[%d]=%d, read_data1[%d]=%d\n",__LINE__,i,attr_data1a[i],i,read_data1[i]);
+!!$
+!!$ /* Close attribute */
+!!$ ret=H5Aclose(attr2);
+!!$ CHECK(ret, FAIL, "H5Aclose");
+
+ 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)
+
+!!$ /* Create group */
+!!$ group = H5Gcreate2(fid1, GROUP1_NAME, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT);
+!!$ CHECK(group, FAIL, "H5Gcreate2");
+!!$
+!!$ /* Create dataspace for attribute */
+!!$ sid2 = H5Screate_simple(ATTR2_RANK, dims3, NULL);
+!!$ CHECK(sid2, FAIL, "H5Screate_simple");
+!!$
+!!$ /* Create an attribute for the group */
+!!$ attr = H5Acreate2(group, ATTR2_NAME, H5T_NATIVE_INT, sid2, H5P_DEFAULT, H5P_DEFAULT);
+!!$ CHECK(attr, FAIL, "H5Acreate2");
+!!$
+!!$ /* Check storage size for attribute */
+!!$ attr_size = H5Aget_storage_size(attr);
+!!$ VERIFY(attr_size, (ATTR2_DIM1 * ATTR2_DIM2 * sizeof(int)), "H5Aget_storage_size");
+!!$
+!!$ /* Try to create the same attribute again (should fail) */
+!!$ ret = H5Acreate2(group, ATTR2_NAME, H5T_NATIVE_INT, sid2, H5P_DEFAULT, H5P_DEFAULT);
+!!$ VERIFY(ret, FAIL, "H5Acreate2");
+!!$
+!!$ /* Write attribute information */
+!!$ ret = H5Awrite(attr, H5T_NATIVE_INT, attr_data2);
+!!$ CHECK(ret, FAIL, "H5Awrite");
+!!$
+!!$ /* Check storage size for attribute */
+!!$ attr_size = H5Aget_storage_size(attr);
+!!$ VERIFY(attr_size, (ATTR2_DIM1 * ATTR2_DIM2 * sizeof(int)), "H5A_get_storage_size");
+!!$
+!!$ /* Close attribute */
+!!$ ret = H5Aclose(attr);
+!!$ CHECK(ret, FAIL, "H5Aclose");
+!!$
+!!$ /* Close Attribute dataspace */
+!!$ ret = H5Sclose(sid2);
+!!$ CHECK(ret, FAIL, "H5Sclose");
+
+!!$ !/* Close Group */
+!!$ ret = H5Gclose(group);
+!!$ CHECK(ret, FAIL, "H5Gclose");
+
+ ! /* 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)
+
+!!$ /* Re-open the file and check on the attributes */
+!!$
+!!$ /* Re-open file */
+!!$ fid = H5Fopen(FILENAME, H5F_ACC_RDONLY, fapl);
+!!$ CHECK(fid, FAIL, "H5Fopen");
+!!$
+!!$ /* Re-open group */
+!!$ gid = H5Gopen2(fid, GROUP1_NAME, H5P_DEFAULT);
+!!$ CHECK(gid, FAIL, "H5Gopen2");
+!!$
+!!$ /* Verify attributes */
+!!$ for(u = 0; u < nattr; u++) {
+!!$ unsigned value; /* Attribute value */
+!!$
+!!$ sprintf(attrname, "a-%06u", u);
+!!$
+!!$ exists = H5Aexists(gid, attrname);
+!!$ VERIFY(exists, TRUE, "H5Aexists");
+!!$
+!!$ exists = H5Aexists_by_name(fid, GROUP1_NAME, attrname, H5P_DEFAULT);
+!!$ VERIFY(exists, TRUE, "H5Aexists_by_name");
+!!$
+!!$ aid = H5Aopen(gid, attrname, H5P_DEFAULT);
+!!$ CHECK(aid, FAIL, "H5Aopen");
+!!$
+!!$ exists = H5Aexists(gid, attrname);
+!!$ VERIFY(exists, TRUE, "H5Aexists");
+!!$
+!!$ exists = H5Aexists_by_name(fid, GROUP1_NAME, attrname, H5P_DEFAULT);
+!!$ VERIFY(exists, TRUE, "H5Aexists_by_name");
+!!$
+!!$ ret = H5Aread(aid, H5T_NATIVE_UINT, &value);
+!!$ CHECK(ret, FAIL, "H5Aread");
+!!$ VERIFY(value, u, "H5Aread");
+!!$
+!!$ ret = H5Aclose(aid);
+!!$ CHECK(ret, FAIL, "H5Aclose");
+!!$ } /* end for */
+!!$
+ ! /* 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: Quincey Koziol
+! * Wednesday, February 21, 2007
+! *
+! *-------------------------------------------------------------------------
+! */
+
+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
+
+ 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 is the correct one */
+ CALL VERIFY("h5aget_info_f",corder,u,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)
+ ! /* Get the attribute's information */
+ CALL VERIFY("h5aget_info_f",corder,u,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 that the object is the correct one */
+ CALL VERIFY("h5aget_info_f",corder,u,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..6eee5c2
--- /dev/null
+++ b/fortran/test/tH5G_1_8.f90
@@ -0,0 +1,2823 @@
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! 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
+
+ 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
+
+ ! /* Verify state of group (compact) */
+ ! if(H5G_has_links_test(group_id, NULL) != TRUE) TEST_ERROR
+
+ !/* Check for out of bound query by index */
+ ! H5E_BEGIN_TRY {
+ ! ret = H5Gget_info_by_idx(group_id, ".", H5_INDEX_NAME, order, (hsize_t)u, &grp_info, H5P_DEFAULT);
+ ! } H5E_END_TRY;
+ ! if(ret >= 0) TEST_ERROR
+
+ ! /* Create more links, to push group into dense form */
+!!$ for(; u < (max_compact * 2); u++) {
+!!$ hid_t group_id2, group_id3; /* Group IDs */
+!!$
+!!$ /* Make name for link */
+!!$ sprintf(objname, "filler %02u", u);
+!!$
+!!$ /* Create hard link, with group object */
+!!$ if((group_id2 = H5Gcreate2(group_id, objname, H5P_DEFAULT, gcpl_id, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$
+!!$ /* Retrieve group's information */
+!!$ if(H5Gget_info(group_id2, &grp_info) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new/empty) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_COMPACT) TEST_ERROR
+!!$ if(grp_info.max_corder != 0) TEST_ERROR
+!!$ if(grp_info.nlinks != 0) TEST_ERROR
+!!$
+!!$ /* Retrieve group's information, by name */
+!!$ if(H5Gget_info_by_name(group_id, objname, &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new/empty) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_COMPACT) TEST_ERROR
+!!$ if(grp_info.max_corder != 0) TEST_ERROR
+!!$ if(grp_info.nlinks != 0) TEST_ERROR
+!!$
+!!$ /* Retrieve group's information, by name */
+!!$ if(H5Gget_info_by_name(group_id2, ".", &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new/empty) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_COMPACT) TEST_ERROR
+!!$ if(grp_info.max_corder != 0) TEST_ERROR
+!!$ if(grp_info.nlinks != 0) TEST_ERROR
+!!$
+!!$
+!!$ /* Create objects in new group created */
+!!$ for(v = 0; v <= u; v++) {
+!!$ /* Make name for link */
+!!$ sprintf(objname2, "filler %02u", v);
+!!$
+!!$ /* Create hard link, with group object */
+!!$ if((group_id3 = H5Gcreate2(group_id2, objname2, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Close group created */
+!!$ if(H5Gclose(group_id3) < 0) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$
+!!$ /* Retrieve group's information */
+!!$ if(H5Gget_info(group_id2, &grp_info) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$ /* Retrieve group's information, by name */
+!!$ if(H5Gget_info_by_name(group_id, objname, &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$ /* Retrieve group's information, by name */
+!!$ if(H5Gget_info_by_name(group_id2, ".", &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check (new) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$
+!!$ /* Retrieve group's information */
+!!$ if(order != H5_ITER_NATIVE) {
+!!$ if(order == H5_ITER_INC) {
+!!$ if(H5Gget_info_by_idx(group_id, ".", idx_type, order, (hsize_t)u, &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ } /* end if */
+!!$ else {
+!!$ if(H5Gget_info_by_idx(group_id, ".", idx_type, order, (hsize_t)0, &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ } /* end else */
+!!$
+!!$ /* Check (new) group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Close group created */
+!!$ if(H5Gclose(group_id2) < 0) TEST_ERROR
+!!$
+!!$
+!!$ /* Retrieve main group's information */
+!!$ if(H5Gget_info(group_id, &grp_info) < 0) TEST_ERROR
+!!$
+!!$ /* Check main group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$ /* Retrieve main group's information, by name */
+!!$ if(H5Gget_info_by_name(file_id, CORDER_GROUP_NAME, &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check main group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$ /* Retrieve main group's information, by name */
+!!$ if(H5Gget_info_by_name(group_id, ".", &grp_info, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Check main group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$
+!!$
+!!$ /* Create soft link in another group, to objects in main group */
+!!$ sprintf(valname, "/%s/%s", CORDER_GROUP_NAME, objname);
+!!$ if(H5Lcreate_soft(valname, soft_group_id, objname, H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Retrieve soft link group's information, by name */
+!!$ if(H5Gget_info(soft_group_id, &grp_info) < 0) TEST_ERROR
+!!$
+!!$ /* Check soft link group's information */
+!!$ if(grp_info.storage_type != H5G_STORAGE_TYPE_DENSE) TEST_ERROR
+!!$ if(grp_info.max_corder != (int64_t)(u + 1)) TEST_ERROR
+!!$ if(grp_info.nlinks != (hsize_t)(u + 1)) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Verify state of group (dense) */
+!!$ if(H5G_is_new_dense_test(group_id) != TRUE) TEST_ERROR
+!!$
+!!$ /* Check for out of bound query by index */
+!!$ H5E_BEGIN_TRY {
+!!$ ret = H5Gget_info_by_idx(group_id, ".", H5_INDEX_NAME, order, (hsize_t)u, &grp_info, H5P_DEFAULT);
+!!$ } H5E_END_TRY;
+!!$ if(ret >= 0) TEST_ERROR
+
+
+ ! /* 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: ud_hard_links
+!!$! *
+!!$! * Purpose: Check that the functionality of hard links can be duplicated
+!!$! * with user-defined links.
+!!$! *
+!!$! *
+!!$! * Programmer: M.S. Breitenfeld
+!!$! * February, 2008
+!!$! *
+!!$! *-------------------------------------------------------------------------
+!!$! */
+!!$!
+!!$!/* Callback functions for UD hard links. */
+!!$!/* UD_hard_create increments the object's reference count */
+!!$
+!!$ SUBROUTINE ud_hard_links(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) :: fid ! /* File ID */
+!!$ INTEGER(HID_T) :: gid ! /* Group IDs */
+!!$
+!!$ CHARACTER(LEN=10) :: objname = 'objname.h5' ! /* Object name */
+!!$ CHARACTER(LEN=10), PARAMETER :: filename = 'filname.h5'
+!!$
+!!$ INTEGER(HSIZE_T) :: name_len ! /* Size of an empty file */
+!!$
+!!$ INTEGER, PARAMETER :: UD_HARD_TYPE=201
+!!$ LOGICAL :: registered
+!!$
+!!$!/* Link information */
+!!$
+!!$! ssize_t name_len; /* Length of object name */
+!!$! h5_stat_size_t empty_size; /* Size of an empty file */
+!!$
+!!$
+!!$ WRITE(*,*) "user-defined hard link (w/new group format)"
+!!$
+!!$ ! /* Set up filename and create file*/
+!!$
+!!$ CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, H5P_DEFAULT_F, fapl)
+!!$ CALL check("h5fcreate_f",error,total_error)
+!!$
+!!$ ! /* Close file */
+!!$ CALL h5fclose_f(fid, error)
+!!$ CALL check("h5fclose_f",error,total_error)
+!!$
+!!$ ! if((empty_size = h5_get_file_size(filename))<0) TEST_ERROR
+!!$
+!!$ ! /* Create file */
+!!$ CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, H5P_DEFAULT_F, fapl)
+!!$ CALL check("h5fcreate_f",error,total_error)
+!!$
+!!$ ! /* Check that external links are registered and UD hard links are not */
+!!$
+!!$ CALL H5Lis_registered(H5L_TYPE_EXTERNAL, registered, error)
+!!$ CALL VerifyLogical("H5Lis_registered", registered, .TRUE., total_error)
+!!$
+!!$ CALL H5Lis_registered(UD_HARD_TYPE, registered, error)
+!!$ CALL VerifyLogical("H5Lis_registered", registered, .FALSE., total_error)
+!!$
+!!$ !/* Register "user-defined hard links" with the library */
+!!$! if(H5Lregister(UD_hard_class) < 0) TEST_ERROR
+!!$
+!!$ /* Check that UD hard links are now registered */
+!!$ if(H5Lis_registered(H5L_TYPE_EXTERNAL) != TRUE) TEST_ERROR
+!!$ if(H5Lis_registered(UD_HARD_TYPE) != TRUE) TEST_ERROR
+!!$
+!!$ /* Create a group for the UD hard link to point to */
+!!$ if((gid = H5Gcreate2(fid, "group", H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Get address for the group to give to the hard link */
+!!$ if(H5Lget_info(fid, "group", &li, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ if(H5Gclose(gid) < 0) TEST_ERROR
+!!$
+!!$
+!!$ /* Create a user-defined "hard link" to the group using the address we got
+!!$ * from H5Lget_info */
+!!$ if(H5Lcreate_ud(fid, "ud_link", UD_HARD_TYPE, &(li.u.address), sizeof(haddr_t), H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Close and re-open file to ensure that data is written to disk */
+!!$ if(H5Fclose(fid) < 0) TEST_ERROR
+!!$ if((fid = H5Fopen(filename, H5F_ACC_RDWR, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Open group through UD link */
+!!$ if((gid = H5Gopen2(fid, "ud_link", H5P_DEFAULT)) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Check name */
+!!$ if((name_len = H5Iget_name( gid, objname, (size_t)NAME_BUF_SIZE )) < 0) TEST_ERROR
+!!$ if(HDstrcmp(objname, "/group")) TEST_ERROR
+!!$
+!!$ /* Create object in group */
+!!$ if((gid2 = H5Gcreate2(gid, "new_group", H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Close groups*/
+!!$ if(H5Gclose(gid2) < 0) TEST_ERROR
+!!$ if(H5Gclose(gid) < 0) TEST_ERROR
+!!$
+!!$ /* Re-open group without using ud link to check that it was created properly */
+!!$ if((gid = H5Gopen2(fid, "group/new_group", H5P_DEFAULT)) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Check name */
+!!$ if((name_len = H5Iget_name( gid, objname, (size_t)NAME_BUF_SIZE )) < 0) TEST_ERROR
+!!$ if(HDstrcmp(objname, "/group/new_group")) TEST_ERROR
+!!$
+!!$ /* Close opened object */
+!!$ if(H5Gclose(gid) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Check that H5Lget_objinfo works on the hard link */
+!!$ if(H5Lget_info(fid, "ud_link", &li, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ /* UD hard links have no query function, thus return a "link length" of 0 */
+!!$ if(li.u.val_size != 0) TEST_ERROR
+!!$ if(UD_HARD_TYPE != li.type) {
+!!$ H5_FAILED();
+!!$ puts(" Unexpected link class - should have been a UD hard link");
+!!$ goto error;
+!!$ } /* end if */
+!!$
+!!$ /* Unlink the group pointed to by the UD link. It shouldn't be
+!!$ * deleted because of the UD link. */
+!!$ if(H5Ldelete(fid, "/group", H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Ensure we can open the group through the UD link */
+!!$ if((gid = H5Gopen2(fid, "ud_link", H5P_DEFAULT)) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Unlink the group contained within it. */
+!!$ if(H5Ldelete(gid, "new_group", H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ if(H5Gclose(gid) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Now delete the UD link. This should cause the group to be
+!!$ * deleted, too. */
+!!$ if(H5Ldelete(fid, "ud_link", H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Close file */
+!!$ if(H5Fclose(fid) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* The file should be empty again. */
+!!$ if(empty_size != h5_get_file_size(filename)) TEST_ERROR
+!!$
+!!$ if(H5Lunregister(UD_HARD_TYPE) < 0) FAIL_STACK_ERROR
+!!$
+!!$ PASSED();
+!!$ return 0;
+!!$
+!!$ error:
+!!$ H5E_BEGIN_TRY {
+!!$ H5Gclose(gid2);
+!!$ H5Gclose(gid);
+!!$ H5Fclose(fid);
+!!$ } H5E_END_TRY;
+!!$ return -1;
+!!$} /* end ud_hard_links() */
+
+!/*-------------------------------------------------------------------------
+! * 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", 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", lheap_size_hint,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)
+
+
+ ! /* Use internal testing routine to check that the group has no links or symbol table */
+ ! if(H5G_is_empty_test(gid) != TRUE) TEST_ERROR
+
+!!$ /* Create first "bottom" group */
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, (unsigned)0);
+!!$ IF((gid2 = H5Gcreate2(gid, objname, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Check on bottom group's status */
+!!$ if(H5G_is_empty_test(gid2) != TRUE) TEST_ERROR
+!!$
+!!$ /* Close bottom group */
+!!$ if(H5Gclose(gid2) < 0) TEST_ERROR
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) == TRUE) TEST_ERROR
+!!$ if(H5G_has_links_test(gid, &nmsgs) != TRUE) TEST_ERROR
+!!$ if(nmsgs != 1) TEST_ERROR
+!!$
+!!$ /* Create several more bottom groups, to push the top group almost to a symbol table */
+!!$ /* (Start counting at '1', since we've already created one bottom group */
+!!$ for(u = 1; u < LIFECYCLE_MAX_COMPACT; u++) {
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$ if((gid2 = H5Gcreate2(gid, objname, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Check on bottom group's status */
+!!$ if(H5G_is_empty_test(gid2) != TRUE) TEST_ERROR
+!!$
+!!$ /* Close bottom group */
+!!$ if(H5Gclose(gid2) < 0) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) == TRUE) TEST_ERROR
+!!$ if(H5G_has_links_test(gid, &nmsgs) != TRUE) TEST_ERROR
+!!$ if(nmsgs != LIFECYCLE_MAX_COMPACT) TEST_ERROR
+!!$ if(H5G_is_new_dense_test(gid) != FALSE) TEST_ERROR
+!!$
+!!$ /* Check that the object header is only one chunk and the space has been allocated correctly */
+!!$ if(H5Oget_info(gid, &oinfo) < 0) TEST_ERROR
+!!$ if(oinfo.hdr.space.total != 151) TEST_ERROR
+!!$ if(oinfo.hdr.space.free != 0) TEST_ERROR
+!!$ if(oinfo.hdr.nmesgs != 6) TEST_ERROR
+!!$ if(oinfo.hdr.nchunks != 1) TEST_ERROR
+!!$
+!!$ /* Create one more "bottom" group, which should push top group into using a symbol table */
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$ if((gid2 = H5Gcreate2(gid, objname, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$
+!!$ /* Check on bottom group's status */
+!!$ if(H5G_is_empty_test(gid2) != TRUE) TEST_ERROR
+!!$
+!!$ /* Close bottom group */
+!!$ if(H5Gclose(gid2) < 0) TEST_ERROR
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) == TRUE) TEST_ERROR
+!!$ if(H5G_has_links_test(gid, NULL) == TRUE) TEST_ERROR
+!!$ if(H5G_is_new_dense_test(gid) != TRUE) TEST_ERROR
+!!$
+!!$ /* Check that the object header is still one chunk and the space has been allocated correctly */
+!!$ if(H5Oget_info(gid, &oinfo) < 0) TEST_ERROR
+!!$ if(oinfo.hdr.space.total != 151) TEST_ERROR
+!!$ if(oinfo.hdr.space.free != 92) TEST_ERROR
+!!$ if(oinfo.hdr.nmesgs != 3) TEST_ERROR
+!!$ if(oinfo.hdr.nchunks != 1) TEST_ERROR
+!!$
+!!$ /* Unlink objects from top group */
+!!$ while(u >= LIFECYCLE_MIN_DENSE) {
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$
+!!$ if(H5Ldelete(gid, objname, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$
+!!$ u--;
+!!$ } /* end while */
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) == TRUE) TEST_ERROR
+!!$ if(H5G_has_links_test(gid, NULL) == TRUE) TEST_ERROR
+!!$ if(H5G_is_new_dense_test(gid) != TRUE) TEST_ERROR
+!!$
+!!$ /* Unlink one more object from the group, which should transform back to using links */
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$ if(H5Ldelete(gid, objname, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ u--;
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) == TRUE) TEST_ERROR
+!!$ if(H5G_has_links_test(gid, &nmsgs) != TRUE) TEST_ERROR
+!!$ if(nmsgs != (LIFECYCLE_MIN_DENSE - 1)) TEST_ERROR
+!!$
+!!$ /* Unlink last two objects from top group */
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$ if(H5Ldelete(gid, objname, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ u--;
+!!$ sprintf(objname, LIFECYCLE_BOTTOM_GROUP, u);
+!!$ if(H5Ldelete(gid, objname, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$
+!!$ /* Check on top group's status */
+!!$ if(H5G_is_empty_test(gid) != TRUE) TEST_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)
+
+!!$ /* Get size of file as empty */
+!!$ if((file_size = h5_get_file_size(filename)) < 0) TEST_ERROR
+!!$
+!!$ /* Verify that file is correct size */
+!!$ if(file_size != empty_size) TEST_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
+
+
+!!$ if(new_format)
+!!$ TESTING("link queries (w/new group format)")
+!!$ else
+!!$ TESTING("link queries")
+
+ ! /* 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)
+
+
+!!$ /* Symbolic link */
+!!$ if(H5Oget_info_by_name(file, "grp1/soft", &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(" Soft link test failed. Link seems not to point to the ");
+!!$ puts(" expected file location.");
+!!$ TEST_ERROR
+!!$ } /* end if */
+
+! CALL H5Lget_val(file, "grp1/soft", INT(LEN(linkval), SIZE_T), linkval, error)
+
+
+!!$ if(H5Lget_val(file, "grp1/soft", linkval, sizeof linkval, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ if(HDstrcmp(linkval, "/d1")) {
+!!$ H5_FAILED();
+!!$ puts(" Soft link test failed. Wrong link value");
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lexists(file, "grp1/soft", H5P_DEFAULT) != TRUE) FAIL_STACK_ERROR
+!!$
+!!$ /* Dangling link */
+!!$ H5E_BEGIN_TRY {
+!!$ status = H5Oget_info_by_name(file, "grp1/dangle", &oinfo2, H5P_DEFAULT);
+!!$ } H5E_END_TRY;
+!!$ if(status >= 0) {
+!!$ H5_FAILED();
+!!$ puts(" H5Oget_info_by_name() should have failed for a dangling link.");
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lget_info(file, "grp1/dangle", &linfo2, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ if(H5L_TYPE_SOFT != linfo2.type) {
+!!$ H5_FAILED();
+!!$ printf(" %d: Unexpected object type should have been a symbolic link\n", __LINE__);
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lget_val(file, "grp1/dangle", linkval, sizeof linkval, H5P_DEFAULT) < 0) {
+!!$ H5_FAILED();
+!!$ printf(" %d: Can't retrieve link value\n", __LINE__);
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(HDstrcmp(linkval, "foobar")) {
+!!$ H5_FAILED();
+!!$ puts(" Dangling link test failed. Wrong link value");
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lexists(file, "grp1/dangle", H5P_DEFAULT) != TRUE) FAIL_STACK_ERROR
+!!$
+!!$ /* Recursive link */
+!!$ H5E_BEGIN_TRY {
+!!$ status = H5Oget_info_by_name(file, "grp1/recursive", &oinfo2, H5P_DEFAULT);
+!!$ } H5E_END_TRY;
+!!$ if(status >= 0) {
+!!$ H5_FAILED();
+!!$ puts(" H5Oget_info_by_name() should have failed for a recursive link.");
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lget_info(file, "grp1/recursive", &linfo2, H5P_DEFAULT) < 0) FAIL_STACK_ERROR
+!!$ if(H5L_TYPE_SOFT != linfo2.type) {
+!!$ H5_FAILED();
+!!$ printf(" %d: Unexpected object type should have been a symbolic link\n", __LINE__);
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(H5Lget_val(file, "grp1/recursive", linkval, sizeof linkval, H5P_DEFAULT) < 0) {
+!!$ H5_FAILED();
+!!$ printf(" %d: Can't retrieve link value\n", __LINE__);
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$ if(HDstrcmp(linkval, "/grp1/recursive")) {
+!!$ H5_FAILED();
+!!$ puts(" Recursive link test failed. Wrong link value");
+!!$ TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Non-existant link */
+!!$ if(H5Lexists(file, "foobar", H5P_DEFAULT) == TRUE) FAIL_STACK_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
+
+ 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
+! CALL h5_fixname_f(filename1, fix_filename1, H5P_DEFAULT_F, error)
+! IF(error .NE. 0) STOP
+
+ ! /* 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 */
+
+ CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(u,HSIZE_T), 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
+!!$
+!!$ /* Delete last link */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify state of group (empty) */
+!!$ if(H5G_has_links_test(group_id, NULL) == TRUE) TEST_ERROR
+!!$
+!!$ /* Create more links, to push group into dense form */
+!!$ for(u = 0; u < (max_compact * 2); u++) {
+!!$ hid_t group_id2; /* Group ID */
+!!$
+!!$ /* Make name for link */
+!!$ sprintf(objname, "filler %02u", u);
+!!$
+!!$ /* Create hard link, with group object */
+!!$ if((group_id2 = H5Gcreate2(group_id, objname, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$ if(H5Gclose(group_id2) < 0) TEST_ERROR
+!!$
+!!$ /* Verify state of group (dense) */
+!!$ if(u >= max_compact)
+!!$ if(H5G_is_new_dense_test(group_id) != TRUE) TEST_ERROR
+!!$
+!!$ /* Verify link information for new link */
+!!$ if(link_info_by_idx_check(group_id, objname, (hsize_t)u, TRUE, use_index) < 0) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Check for out of bound deletion again */
+!!$ H5E_BEGIN_TRY {
+!!$ ret = H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)u, H5P_DEFAULT);
+!!$ } H5E_END_TRY;
+!!$ if(ret >= 0) TEST_ERROR
+!!$
+!!$ /* Delete links from dense group, in appropriate order */
+!!$ for(u = 0; u < ((max_compact * 2) - 1); u++) {
+!!$ /* Delete first link in appropriate order */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for first link in appropriate order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", idx_type, order, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC) {
+!!$ if(linfo.corder != (u + 1)) TEST_ERROR
+!!$ } /* end if */
+!!$ else {
+!!$ if(linfo.corder != ((max_compact * 2) - (u + 2))) TEST_ERROR
+!!$ } /* end else */
+!!$
+!!$ /* Verify the name for first link in appropriate order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", idx_type, order, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC)
+!!$ sprintf(objname, "filler %02u", (u + 1));
+!!$ else
+!!$ sprintf(objname, "filler %02u", ((max_compact * 2) - (u + 2)));
+!!$ if(HDstrcmp(objname, tmpname)) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Delete last link */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify state of group (empty) */
+!!$ if(H5G_has_links_test(group_id, NULL) == TRUE) TEST_ERROR
+!!$ if(H5G_is_new_dense_test(group_id) == TRUE) TEST_ERROR
+!!$
+!!$ /* Check for deletion on empty group again */
+!!$ H5E_BEGIN_TRY {
+!!$ ret = H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT);
+!!$ } H5E_END_TRY;
+!!$ if(ret >= 0) TEST_ERROR
+!!$
+!!$
+!!$ /* Delete links in middle */
+!!$
+!!$
+!!$ /* Create more links, to push group into dense form */
+!!$ for(u = 0; u < (max_compact * 2); u++) {
+!!$ hid_t group_id2; /* Group ID */
+!!$
+!!$ /* Make name for link */
+!!$ sprintf(objname, "filler %02u", u);
+!!$
+!!$ /* Create hard link, with group object */
+!!$ if((group_id2 = H5Gcreate2(group_id, objname, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR
+!!$ if(H5Gclose(group_id2) < 0) TEST_ERROR
+!!$
+!!$ /* Verify state of group (dense) */
+!!$ if(u >= max_compact)
+!!$ if(H5G_is_new_dense_test(group_id) != TRUE) TEST_ERROR
+!!$
+!!$ /* Verify link information for new link */
+!!$ if(link_info_by_idx_check(group_id, objname, (hsize_t)u, TRUE, use_index) < 0) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Delete every other link from dense group, in appropriate order */
+!!$ for(u = 0; u < max_compact; u++) {
+!!$ /* Delete link */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)u, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for current link in appropriate order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", idx_type, order, (hsize_t)u, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC) {
+!!$ if(linfo.corder != ((u * 2) + 1)) TEST_ERROR
+!!$ } /* end if */
+!!$ else {
+!!$ if(linfo.corder != ((max_compact * 2) - ((u * 2) + 2))) TEST_ERROR
+!!$ } /* end else */
+!!$
+!!$ /* Verify the name for current link in appropriate order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", idx_type, order, (hsize_t)u, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC)
+!!$ sprintf(objname, "filler %02u", ((u * 2) + 1));
+!!$ else
+!!$ sprintf(objname, "filler %02u", ((max_compact * 2) - ((u * 2) + 2)));
+!!$ if(HDstrcmp(objname, tmpname)) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Delete remaining links from dense group, in appropriate order */
+!!$ for(u = 0; u < (max_compact - 1); u++) {
+!!$ /* Delete link */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for first link in appropriate order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", idx_type, order, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC) {
+!!$ if(linfo.corder != ((u * 2) + 3)) TEST_ERROR
+!!$ } /* end if */
+!!$ else {
+!!$ if(linfo.corder != ((max_compact * 2) - ((u * 2) + 4))) TEST_ERROR
+!!$ } /* end else */
+!!$
+!!$ /* Verify the name for first link in appropriate order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", idx_type, order, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(order == H5_ITER_INC)
+!!$ sprintf(objname, "filler %02u", ((u * 2) + 3));
+!!$ else
+!!$ sprintf(objname, "filler %02u", ((max_compact * 2) - ((u * 2) + 4)));
+!!$ if(HDstrcmp(objname, tmpname)) TEST_ERROR
+!!$ } /* end for */
+!!$
+!!$ /* Delete last link */
+!!$ if(H5Ldelete_by_idx(group_id, ".", idx_type, order, (hsize_t)0, H5P_DEFAULT) < 0) TEST_ERROR
+!!$
+!!$ /* Verify state of group (empty) */
+!!$ if(H5G_has_links_test(group_id, NULL) == TRUE) TEST_ERROR
+!!$ if(H5G_is_new_dense_test(group_id) == TRUE) TEST_ERROR
+!!$
+!!$
+!!$
+ ! /* 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
+!!$
+!!$ return 0;
+!!$
+!!$error:
+!!$ H5E_BEGIN_TRY {
+!!$ H5Pclose(gcpl_id);
+!!$ H5Gclose(group_id);
+!!$ H5Fclose(file_id);
+!!$ } H5E_END_TRY;
+!!$ return -1;
+!!$} /* end delete_by_idx() */
+
+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
+
+ size_tmp = INT(3,SIZE_T)
+ CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), size_tmp, tmpname_small, error)
+ 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
+ size_tmp = INT(LEN(tmpname),SIZE_T)
+ CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), size_tmp, tmpname, error)
+ 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)
+
+ size_tmp = INT(LEN(tmpname_big),SIZE_T)
+ CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), size_tmp, tmpname_big, error)
+ 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
+
+!!$ size_tmp = INT(4,SIZE_T)
+!!$ CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), size_tmp, tmpname, error)
+!!$ CALL check("H5Lget_name_by_idx_f", error, total_error)
+!!$ CALL verifyString("H5Lget_name_by_idx_f", linkname, tmpname, total_error)
+
+
+!!$
+!!$ if(H5Lget_name_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_INC, n, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(linkname, tmpname)) TEST_ERROR
+
+!!$ /* Don't test "native" order if there is no creation order index, since
+!!$ * there's not a good way to easily predict the link's order in the name
+!!$ * index.
+!!$ */
+!!$ if(use_index) {
+!!$ /* Verify the link information for first link, in native creation order (which is increasing) */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_NATIVE, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for new link, in native creation order (which is increasing) */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_NATIVE, n, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != (int64_t)n) TEST_ERROR
+!!$
+!!$ /* Verify value for new soft link, in native creation order (which is increasing) */
+!!$ if(!hard_link) {
+!!$ HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_val_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_NATIVE, n, tmpval, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(valname, tmpval)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for new link, in native creation order (which is increasing) */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_NATIVE, n, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(linkname, tmpname)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Verify the link information for first link, in decreasing creation order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, n, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for new link, in decreasing creation order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != (int64_t)n) TEST_ERROR
+!!$
+!!$ /* Verify value for new soft link, in decreasing creation order */
+!!$ if(!hard_link) {
+!!$ HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_val_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, (hsize_t)0, tmpval, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(valname, tmpval)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for new link, in decreasing creation order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", H5_INDEX_CRT_ORDER, H5_ITER_DEC, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(linkname, tmpname)) TEST_ERROR
+!!$
+!!$
+!!$ /* Verify the link information for first link, in increasing link name order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_INC, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for new link, in increasing link name order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_INC, n, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != (int64_t)n) TEST_ERROR
+!!$
+!!$ /* Verify value for new soft link, in increasing link name order */
+!!$ if(!hard_link) {
+!!$ HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_val_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_INC, n, tmpval, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(valname, tmpval)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for new link, in increasing link name order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_INC, n, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(linkname, tmpname)) TEST_ERROR
+!!$
+!!$ /* Don't test "native" order queries on link name order, since there's not
+!!$ * a good way to easily predict the order of the links in the name index.
+!!$ */
+!!$
+!!$ /* Verify the link information for first link, in decreasing link name order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_DEC, n, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != 0) TEST_ERROR
+!!$
+!!$ /* Verify the link information for new link, in decreasing link name order */
+!!$ HDmemset(&linfo, 0, sizeof(linfo));
+!!$ if(H5Lget_info_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_DEC, (hsize_t)0, &linfo, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(linfo.corder != (int64_t)n) TEST_ERROR
+!!$
+!!$ /* Verify value for new soft link, in decreasing link name order */
+!!$ if(!hard_link) {
+!!$ HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_val_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_DEC, (hsize_t)0, tmpval, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(valname, tmpval)) TEST_ERROR
+!!$ } /* end if */
+!!$
+!!$ /* Verify the name for new link, in decreasing link name order */
+!!$ HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE);
+!!$ if(H5Lget_name_by_idx(group_id, ".", H5_INDEX_NAME, H5_ITER_DEC, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT) < 0) TEST_ERROR
+!!$ if(HDstrcmp(linkname, tmpname)) TEST_ERROR
+!!$
+!!$ /* Success */
+!!$ return(0);
+!!$
+!!$error:
+!!$ /* Failure */
+!!$ return(-1);
+!!$} /* end link_info_by_idx_check() */
+
+ 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
+
+ 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
+ CALL VERIFY("H5Sget_simple_extent_dims", dimsout(i), extend_dim(i), total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims", maxdimsout(i), dims(i), 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)"
+
+!!$ /* Make certain test is valid */
+!!$ /* XXX: should probably make a "generic" test that creates the proper
+!!$ * # of links based on this value - QAK
+!!$ */
+!!$ HDassert(H5L_NUM_LINKS == 16);
+
+ ! /* 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..d0c3f16
--- /dev/null
+++ b/fortran/test/tH5O.f90
@@ -0,0 +1,208 @@
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! 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 */
+!!$ test_h5o_plist(); /* 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
+ CHARACTER(LEN=8), PARAMETER :: TEST_FILENAME = 'TestFile'
+ INTEGER, PARAMETER :: TEST6_DIM1 = 2, TEST6_DIM2 = 5
+ INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/)
+ INTEGER, DIMENSION(1:TEST6_DIM1,1: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",error,total_error)
+
+ CALL H5Tcommit_anon_f(file_id, type_id, error) ! using no optional parameters
+ CALL check("H5Tcommit_anon",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 */
+
+ CALL h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, wdata, dims, error, &
+ mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F)
+ CALL check("h5dwrite_f", error, total_error)
+
+ ! /* Read the data back */
+ CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, &
+ mem_space_id=H5S_ALL_F, file_space_id=H5S_ALL_F, xfer_prp = H5P_DEFAULT_F)
+ 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 */
+ CALL h5dread_f(dset_id, H5T_NATIVE_INTEGER, rdata, dims, error, &
+ H5S_ALL_F, H5S_ALL_F, xfer_prp = H5P_DEFAULT_F)
+ 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
diff --git a/fortran/test/tH5R.f90 b/fortran/test/tH5R.f90
index 687bb06..9dfc374 100644
--- a/fortran/test/tH5R.f90
+++ b/fortran/test/tH5R.f90
@@ -17,377 +17,435 @@
!
! 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
-
- 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)
+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)
+ CALL VERIFY("H5Rget_name_f", buf_size,INT(7,SIZE_T), 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", buf_size,INT(7,SIZE_T),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", buf_size,INT(14,SIZE_T),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", buf_size,INT(7,SIZE_T),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", buf_size,INT(7,SIZE_T),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", buf_size,INT(7,SIZE_T),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..4857a2b 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 :: 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..eb033b6 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 :: verifyLogical
+!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
generated by cgit v0.12 at 2024-11-09 20:53:00 (GMT)