summaryrefslogtreecommitdiffstats
path: root/fortran/test
diff options
context:
space:
mode:
authorScot Breitenfeld <brtnfld@hdfgroup.org>2011-08-18 14:32:47 (GMT)
committerScot Breitenfeld <brtnfld@hdfgroup.org>2011-08-18 14:32:47 (GMT)
commita9c065c5ce65bb7dca560d53642574dba608dc78 (patch)
tree2d36b7afd3f3a83314db25aba081e95254d28841 /fortran/test
parenta968e2d409d975ac5b584680620d2589b0409f88 (diff)
downloadhdf5-a9c065c5ce65bb7dca560d53642574dba608dc78.zip
hdf5-a9c065c5ce65bb7dca560d53642574dba608dc78.tar.gz
hdf5-a9c065c5ce65bb7dca560d53642574dba608dc78.tar.bz2
[svn-r21248] Mereged the F2003 branch into the trunk.
Items merged: fortran directory, src/libhdf5.settings.in configure.in configure MANIFEST Tested: (all platforms used by daily tests, both with --enable-fortran and --enable-fortran2003)
Diffstat (limited to 'fortran/test')
-rw-r--r--fortran/test/Makefile.am23
-rw-r--r--fortran/test/Makefile.in45
-rw-r--r--fortran/test/fflush1.f9019
-rw-r--r--fortran/test/fflush2.f9021
-rw-r--r--fortran/test/fortranlib_test.f9017
-rw-r--r--fortran/test/fortranlib_test_1_8.f90353
-rw-r--r--fortran/test/fortranlib_test_F03.f90168
-rw-r--r--fortran/test/t.c16
-rw-r--r--fortran/test/tH5A.f9015
-rw-r--r--fortran/test/tH5A_1_8.f90588
-rw-r--r--fortran/test/tH5D.f9022
-rw-r--r--fortran/test/tH5E.f9018
-rw-r--r--fortran/test/tH5E_F03.f90210
-rw-r--r--fortran/test/tH5F.f9023
-rw-r--r--fortran/test/tH5G.f9015
-rw-r--r--fortran/test/tH5G_1_8.f90150
-rw-r--r--fortran/test/tH5I.f9030
-rw-r--r--fortran/test/tH5L_F03.f90334
-rw-r--r--fortran/test/tH5O.f9014
-rw-r--r--fortran/test/tH5P.f9055
-rw-r--r--fortran/test/tH5P_F03.f90364
-rw-r--r--fortran/test/tH5R.f9063
-rw-r--r--fortran/test/tH5S.f9024
-rw-r--r--fortran/test/tH5Sselect.f90143
-rw-r--r--fortran/test/tH5T.f9018
-rw-r--r--fortran/test/tH5T_F03.f902549
-rw-r--r--fortran/test/tH5VL.f9022
-rw-r--r--fortran/test/tH5Z.f9014
-rw-r--r--fortran/test/tf.f9063
29 files changed, 4548 insertions, 848 deletions
diff --git a/fortran/test/Makefile.am b/fortran/test/Makefile.am
index fb4d6ca..b261785 100644
--- a/fortran/test/Makefile.am
+++ b/fortran/test/Makefile.am
@@ -35,8 +35,21 @@ else
AM_LDFLAGS+=-static
endif
+# Check if the compiler supports the Fortran 2003 standard
+# which should include the intrinsic module iso_c_binding
+if FORTRAN_2003_CONDITIONAL_F
+ ff_PREFIX = F03
+else
+ ff_PREFIX = F90
+endif
+
# Our main targets, the tests themselves
TEST_PROG=fortranlib_test fflush1 fflush2 fortranlib_test_1_8
+
+if FORTRAN_2003_CONDITIONAL_F
+ TEST_PROG += fortranlib_test_F03
+endif
+
check_PROGRAMS=$(TEST_PROG)
libh5test_fortran_la_SOURCES= tf.f90 t.c
@@ -51,8 +64,14 @@ fortranlib_test_SOURCES = fortranlib_test.f90 \
tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90
fortranlib_test_1_8_SOURCES = fortranlib_test_1_8.f90 \
- tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90
-
+ tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90
+
+if FORTRAN_2003_CONDITIONAL_F
+ fortranlib_test_F03_SOURCES = fortranlib_test_F03.f90 \
+ tH5F.f90 tH5E_F03.f90 tH5L_F03.f90 tH5P_F03.f90 tH5T_F03.f90
+endif
+
+
fflush1_SOURCES=fflush1.f90
fflush2_SOURCES=fflush2.f90
diff --git a/fortran/test/Makefile.in b/fortran/test/Makefile.in
index 080544c..27198a8 100644
--- a/fortran/test/Makefile.in
+++ b/fortran/test/Makefile.in
@@ -59,7 +59,8 @@ DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
# want to build a shared C library and a static Fortran library. If so,
# pass the -static flag to the library linker.
@FORTRAN_SHARED_CONDITIONAL_FALSE@am__append_1 = -static
-check_PROGRAMS = $(am__EXEEXT_1)
+@FORTRAN_2003_CONDITIONAL_F_TRUE@am__append_2 = fortranlib_test_F03
+check_PROGRAMS = $(am__EXEEXT_2)
TESTS = $(check_PROGRAMS)
subdir = fortran/test
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
@@ -77,8 +78,10 @@ libh5test_fortran_la_OBJECTS = $(am_libh5test_fortran_la_OBJECTS)
AM_V_lt = $(am__v_lt_$(V))
am__v_lt_ = $(am__v_lt_$(AM_DEFAULT_VERBOSITY))
am__v_lt_0 = --silent
-am__EXEEXT_1 = fortranlib_test$(EXEEXT) fflush1$(EXEEXT) \
- fflush2$(EXEEXT) fortranlib_test_1_8$(EXEEXT)
+@FORTRAN_2003_CONDITIONAL_F_TRUE@am__EXEEXT_1 = \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ fortranlib_test_F03$(EXEEXT)
+am__EXEEXT_2 = fortranlib_test$(EXEEXT) fflush1$(EXEEXT) \
+ fflush2$(EXEEXT) fortranlib_test_1_8$(EXEEXT) $(am__EXEEXT_1)
am_fflush1_OBJECTS = fflush1.$(OBJEXT)
fflush1_OBJECTS = $(am_fflush1_OBJECTS)
fflush1_LDADD = $(LDADD)
@@ -114,6 +117,18 @@ 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)
+am__fortranlib_test_F03_SOURCES_DIST = fortranlib_test_F03.f90 \
+ tH5F.f90 tH5E_F03.f90 tH5L_F03.f90 tH5P_F03.f90 tH5T_F03.f90
+@FORTRAN_2003_CONDITIONAL_F_TRUE@am_fortranlib_test_F03_OBJECTS = fortranlib_test_F03.$(OBJEXT) \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5F.$(OBJEXT) \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5E_F03.$(OBJEXT) \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5L_F03.$(OBJEXT) \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5P_F03.$(OBJEXT) \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5T_F03.$(OBJEXT)
+fortranlib_test_F03_OBJECTS = $(am_fortranlib_test_F03_OBJECTS)
+fortranlib_test_F03_LDADD = $(LDADD)
+fortranlib_test_F03_DEPENDENCIES = libh5test_fortran.la $(LIBH5TEST) \
+ $(LIBH5F) $(LIBHDF5)
DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/src
depcomp = $(SHELL) $(top_srcdir)/bin/depcomp
am__depfiles_maybe = depfiles
@@ -155,10 +170,11 @@ am__v_GEN_ = $(am__v_GEN_$(AM_DEFAULT_VERBOSITY))
am__v_GEN_0 = @echo " GEN " $@;
SOURCES = $(libh5test_fortran_la_SOURCES) $(fflush1_SOURCES) \
$(fflush2_SOURCES) $(fortranlib_test_SOURCES) \
- $(fortranlib_test_1_8_SOURCES)
+ $(fortranlib_test_1_8_SOURCES) $(fortranlib_test_F03_SOURCES)
DIST_SOURCES = $(libh5test_fortran_la_SOURCES) $(fflush1_SOURCES) \
$(fflush2_SOURCES) $(fortranlib_test_SOURCES) \
- $(fortranlib_test_1_8_SOURCES)
+ $(fortranlib_test_1_8_SOURCES) \
+ $(am__fortranlib_test_F03_SOURCES_DIST)
ETAGS = etags
CTAGS = ctags
am__tty_colors = \
@@ -232,6 +248,7 @@ F9XMODEXT = @F9XMODEXT@
F9XMODFLAG = @F9XMODFLAG@
F9XSUFFIXFLAG = @F9XSUFFIXFLAG@
FC = @FC@
+FC2003 = @FC2003@
FCFLAGS = @FCFLAGS@
FCFLAGS_f90 = @FCFLAGS_f90@
FCLIBS = @FCLIBS@
@@ -252,10 +269,12 @@ H5_LONE_COLON = @H5_LONE_COLON@
H5_VERSION = @H5_VERSION@
HADDR_T = @HADDR_T@
HAVE_DMALLOC = @HAVE_DMALLOC@
+HAVE_FORTRAN_2003 = @HAVE_FORTRAN_2003@
HDF5_HL = @HDF5_HL@
HDF5_INTERFACES = @HDF5_INTERFACES@
HDF_CXX = @HDF_CXX@
HDF_FORTRAN = @HDF_FORTRAN@
+HDF_FORTRAN2003 = @HDF_FORTRAN2003@
HID_T = @HID_T@
HL = @HL@
HL_FOR = @HL_FOR@
@@ -451,9 +470,15 @@ INCLUDES = -I$(top_srcdir)/src -I$(top_builddir)/fortran/src
# The Fortran test library
noinst_LTLIBRARIES = libh5test_fortran.la
+@FORTRAN_2003_CONDITIONAL_F_FALSE@ff_PREFIX = F90
+
+# Check if the compiler supports the Fortran 2003 standard
+# which should include the intrinsic module iso_c_binding
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ff_PREFIX = F03
# Our main targets, the tests themselves
-TEST_PROG = fortranlib_test fflush1 fflush2 fortranlib_test_1_8
+TEST_PROG = fortranlib_test fflush1 fflush2 fortranlib_test_1_8 \
+ $(am__append_2)
libh5test_fortran_la_SOURCES = tf.f90 t.c
# Source files are used for both the library and fortranlib_test.
@@ -465,7 +490,10 @@ fortranlib_test_SOURCES = fortranlib_test.f90 \
tH5Sselect.f90 tH5P.f90 tH5A.f90 tH5I.f90 tH5G.f90 tH5E.f90
fortranlib_test_1_8_SOURCES = fortranlib_test_1_8.f90 \
- tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90
+ tH5F.f90 tH5O.f90 tH5A_1_8.f90 tH5G_1_8.f90
+
+@FORTRAN_2003_CONDITIONAL_F_TRUE@fortranlib_test_F03_SOURCES = fortranlib_test_F03.f90 \
+@FORTRAN_2003_CONDITIONAL_F_TRUE@ tH5F.f90 tH5E_F03.f90 tH5L_F03.f90 tH5P_F03.f90 tH5T_F03.f90
fflush1_SOURCES = fflush1.f90
fflush2_SOURCES = fflush2.f90
@@ -559,6 +587,9 @@ fortranlib_test$(EXEEXT): $(fortranlib_test_OBJECTS) $(fortranlib_test_DEPENDENC
fortranlib_test_1_8$(EXEEXT): $(fortranlib_test_1_8_OBJECTS) $(fortranlib_test_1_8_DEPENDENCIES)
@rm -f fortranlib_test_1_8$(EXEEXT)
$(AM_V_FCLD)$(FCLINK) $(fortranlib_test_1_8_OBJECTS) $(fortranlib_test_1_8_LDADD) $(LIBS)
+fortranlib_test_F03$(EXEEXT): $(fortranlib_test_F03_OBJECTS) $(fortranlib_test_F03_DEPENDENCIES)
+ @rm -f fortranlib_test_F03$(EXEEXT)
+ $(AM_V_FCLD)$(FCLINK) $(fortranlib_test_F03_OBJECTS) $(fortranlib_test_F03_LDADD) $(LIBS)
mostlyclean-compile:
-rm -f *.$(OBJEXT)
diff --git a/fortran/test/fflush1.f90 b/fortran/test/fflush1.f90
index 8767e55..d35bfff 100644
--- a/fortran/test/fflush1.f90
+++ b/fortran/test/fflush1.f90
@@ -1,3 +1,15 @@
+!****h* root/fortran/test/fflush1.f90
+!
+! NAME
+! FFLUSH1EXAMPLE
+!
+! FUNCTION
+! This is the first half of a two-part test that makes sure
+! that a file can be read after an application crashes as long
+! as the file was flushed first. We simulate by exit the
+! the program using stop statement
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,12 +25,7 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
-!
-! Purpose: This is the first half of a two-part test that makes sure
-! that a file can be read after an application crashes as long
-! as the file was flushed first. We simulate by exit the
-! the program using stop statement
-!
+!*****
PROGRAM FFLUSH1EXAMPLE
diff --git a/fortran/test/fflush2.f90 b/fortran/test/fflush2.f90
index a4710e2..d699150 100644
--- a/fortran/test/fflush2.f90
+++ b/fortran/test/fflush2.f90
@@ -1,3 +1,15 @@
+!****h* root/fortran/test/fflush2.f90
+!
+! NAME
+! fflush2.f90
+!
+! FUNCTION
+! This is the second half of a two-part test that makes sure
+! that a file can be read after an application crashes as long
+! as the file was flushed first. This half tries to read the
+! file created by the first half.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,12 +25,7 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
-!
-! Purpose: This is the second half of a two-part test that makes sure
-! that a file can be read after an application crashes as long
-! as the file was flushed first. This half tries to read the
-! file created by the first half.
-!
+!*****
PROGRAM FFLUSH2EXAMPLE
@@ -89,7 +96,6 @@
write(*,*) "Cannot modify filename"
CALL h5_exit_f (1)
endif
- print *, "filename=", filename, "fix_filename=", fix_filename
CALL h5fopen_f(fix_filename, H5F_ACC_RDONLY_F, file_id, error)
CALL check("h5fopen_f",error,total_error)
@@ -135,7 +141,6 @@
!In case error happens, exit.
!
IF (error == -1) CALL h5_exit_f (1)
-
!
!Close the datatype
!
diff --git a/fortran/test/fortranlib_test.f90 b/fortran/test/fortranlib_test.f90
index 08580c8..6268d15 100644
--- a/fortran/test/fortranlib_test.f90
+++ b/fortran/test/fortranlib_test.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/fortranlib_test.f90
+!
+! NAME
+! fortranlib_test.f90
+!
+! FUNCTION
+! Basic testing of Fortran API's functionality.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,10 +22,8 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
-!
-!
-! Testing Fortran functionality.
-!
+!*****
+
PROGRAM fortranlibtest
USE HDF5
@@ -142,7 +149,7 @@ PROGRAM fortranlibtest
ret_total_error = 0
CALL test_select_bounds(cleanup, ret_total_error)
CALL write_test_status(ret_total_error, ' Selection bounds test ', total_error)
-
+
! write(*,*)
! write(*,*) '========================================='
! write(*,*) 'Testing DATATYPE interface '
diff --git a/fortran/test/fortranlib_test_1_8.f90 b/fortran/test/fortranlib_test_1_8.f90
index fac83eb..dbada6b 100644
--- a/fortran/test/fortranlib_test_1_8.f90
+++ b/fortran/test/fortranlib_test_1_8.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/fortranlib_test_1_8.f90
+!
+! NAME
+! fortranlib_test_1_8.f90
+!
+! FUNCTION
+! Basic testing of Fortran API's introduced in 1.8 release.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,10 +22,8 @@
! 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
@@ -81,20 +88,22 @@ PROGRAM fortranlibtest
total_error)
ret_total_error = 0
- CALL test_genprop_basic_class(cleanup, ret_total_error)
+ CALL test_h5s_encode(cleanup, ret_total_error)
CALL write_test_status(ret_total_error, &
- ' Testing basic generic properties', &
+ ' Testing dataspace encoding and decoding', &
total_error)
ret_total_error = 0
- CALL test_h5s_encode(cleanup, ret_total_error)
+ CALL test_nbit(cleanup, ret_total_error )
CALL write_test_status(ret_total_error, &
- ' Testing dataspace encoding and decoding', &
+ ' Testing nbit filter', &
total_error)
-
-
-! CALL test_hard_query(group_total_error)
+ ret_total_error = 0
+ CALL test_scaleoffset(cleanup, ret_total_error )
+ CALL write_test_status(ret_total_error, &
+ ' Testing scaleoffset filter', &
+ total_error)
WRITE(*,*)
@@ -129,7 +138,6 @@ SUBROUTINE dtransform(cleanup, total_error)
INTEGER(SIZE_T) :: size
-
CALL H5Fcreate_f("dtransform.h5", H5F_ACC_TRUNC_F, file_id, error)
CALL check("dtransform.H5Fcreate_f", error, total_error)
@@ -194,10 +202,6 @@ SUBROUTINE test_genprop_basic_class(cleanup, total_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)
@@ -277,13 +281,10 @@ SUBROUTINE test_h5s_encode(cleanup, total_error)
INTEGER :: rank !/* LOGICAL rank of dataspace */
INTEGER(size_t) :: sbuf_size=0, scalar_size=0
-! Make sure the size is large, need variable length in fortran 2003
+! Make sure the size is large
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/)
@@ -292,11 +293,8 @@ SUBROUTINE test_h5s_encode(cleanup, total_error)
INTEGER(hsize_t), DIMENSION(1:3) :: BLOCK = (/1, 3, 1/)
INTEGER :: space_type
-
-! H5S_sel_type sel_type;
-! hssize_t nblocks;
!
- !Dataset dimensions
+ ! Dataset dimensions
!
INTEGER, PARAMETER :: SPACE1_DIM1= 3, SPACE1_DIM2=15, SPACE1_DIM3=13
@@ -304,9 +302,6 @@ SUBROUTINE test_h5s_encode(cleanup, total_error)
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.
! *-------------------------------------------------------------------------
@@ -326,7 +321,6 @@ SUBROUTINE test_h5s_encode(cleanup, total_error)
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 */
@@ -347,23 +341,6 @@ SUBROUTINE test_h5s_encode(cleanup, 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.
!
@@ -423,3 +400,289 @@ SUBROUTINE test_h5s_encode(cleanup, total_error)
END SUBROUTINE test_h5s_encode
+!-------------------------------------------------------------------------
+! Function: test_nbit
+!
+! Purpose: Tests (real) datatype for nbit filter
+!
+! Return: Success: 0
+! Failure: >0
+!
+! Programmer: M. Scot Breitenfeld
+! Decemeber 7, 2010
+!
+! Modifications:
+!
+!-------------------------------------------------------------------------
+!
+
+SUBROUTINE test_nbit(cleanup, total_error )
+
+ USE HDF5
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: wp = KIND(1.0)
+ LOGICAL, INTENT(IN) :: cleanup
+ INTEGER, INTENT(INOUT) :: total_error
+ INTEGER(hid_t) :: file
+
+ INTEGER(hid_t) :: dataset, datatype, space, dc
+ INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2,5/)
+ INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2,5/)
+ ! orig_data[] are initialized to be within the range that can be represented by
+ ! dataset datatype (no precision loss during datatype conversion)
+ !
+ REAL(kind=wp), DIMENSION(1:2,1:5) :: orig_data = RESHAPE( (/188384.00, 19.103516, -1.0831790e9, -84.242188, &
+ 5.2045898, -49140.000, 2350.2500, -3.2110596e-1, 6.4998865e-5, -0.0000000/) , (/2,5/) )
+ REAL(kind=wp), DIMENSION(1:2,1:5) :: new_data
+ INTEGER(size_t) :: PRECISION, offset
+ INTEGER :: error
+ LOGICAL :: status
+ INTEGER*8 :: ii
+ INTEGER(size_t) :: i, j
+
+
+ ! check to see if filter is available
+ CALL H5Zfilter_avail_f(H5Z_FILTER_NBIT_F, status, error)
+ IF(.NOT.status)THEN ! We don't have H5Z_FILTER_NBIT_F filter
+ total_error = -1 ! so return
+ RETURN
+ ENDIF
+
+ CALL H5Fcreate_f("nbit.h5", H5F_ACC_TRUNC_F, file, error)
+ CALL check("H5Fcreate_f", error, total_error)
+
+ ! Define dataset datatype (integer), and set precision, offset
+ CALL H5Tcopy_f(H5T_IEEE_F32BE, datatype, error)
+ CALL CHECK(" H5Tcopy_f", error, total_error)
+ CALL H5Tset_fields_f(datatype, 26_size_t, 20_size_t, 6_size_t, 7_size_t, 13_size_t, error)
+ CALL CHECK(" H5Tset_fields_f", error, total_error)
+ offset = 7
+ CALL H5Tset_offset_f(datatype, offset, error)
+ CALL CHECK(" H5Tset_offset_f", error, total_error)
+ PRECISION = 20
+ CALL H5Tset_precision_f(datatype,PRECISION, error)
+ CALL CHECK(" H5Tset_precision_f", error, total_error)
+
+ CALL H5Tset_size_f(datatype, 4_size_t, error)
+ CALL CHECK(" H5Tset_size_f", error, total_error)
+
+ CALL H5Tset_ebias_f(datatype, 31_size_t, error)
+ CALL CHECK(" H5Tset_ebias_f", error, total_error)
+
+ ! Create the data space
+ CALL H5Screate_simple_f(2, dims, space, error)
+ CALL CHECK(" H5Screate_simple_f", error, total_error)
+
+ ! USE nbit filter
+ CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error)
+ CALL CHECK(" H5Pcreate_f", error, total_error)
+
+ CALL H5Pset_chunk_f(dc, 2, chunk_dim, error)
+ CALL CHECK(" H5Pset_chunk_f", error, total_error)
+ CALL H5Pset_nbit_f(dc, error)
+ CALL CHECK(" H5Pset_nbit_f", error, total_error)
+
+ ! Create the dataset
+ CALL H5Dcreate_f(file, "nbit_real", datatype, &
+ space, dataset, error, dc)
+ CALL CHECK(" H5Dcreate_f", error, total_error)
+
+ !----------------------------------------------------------------------
+ ! STEP 1: Test nbit by setting up a chunked dataset and writing
+ ! to it.
+ !----------------------------------------------------------------------
+ !
+ CALL H5Dwrite_f(dataset, H5T_NATIVE_REAL, orig_data, dims, error)
+ CALL CHECK(" H5Dwrite_f", error, total_error)
+
+ !----------------------------------------------------------------------
+ ! STEP 2: Try to read the data we just wrote.
+ !----------------------------------------------------------------------
+ !
+ CALL H5Dread_f(dataset, H5T_NATIVE_REAL, new_data, dims, error)
+ CALL CHECK(" H5Dread_f", error, total_error)
+
+ ! Check that the values read are the same as the values written
+ ! Assume size of long long = size of double
+ !
+ i_loop: DO i = 1, dims(1)
+ j_loop: DO j = 1, dims(2)
+ IF(.NOT.(orig_data(i,j).EQ.orig_data(i,j))) CYCLE ! skip IF value is NaN
+ IF(new_data(i,j) .NE. orig_data(i,j))THEN
+ total_error = total_error + 1
+ WRITE(*,'(" Read different values than written.")')
+ WRITE(*,'(" At index ", 2(1X,I0))') i, j
+ EXIT i_loop
+ END IF
+ ENDDO j_loop
+ ENDDO i_loop
+
+ !----------------------------------------------------------------------
+ ! Cleanup
+ !----------------------------------------------------------------------
+ !
+ CALL H5Tclose_f(datatype, error)
+ CALL CHECK(" H5Tclose_f", error, total_error)
+ CALL H5Pclose_f(dc, error)
+ CALL CHECK(" H5Pclose_f", error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL CHECK(" H5Sclose_f", error, total_error)
+ CALL H5Dclose_f(dataset, error)
+ CALL CHECK(" H5Dclose_f", error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL CHECK(" H5Fclose_f", error, total_error)
+
+END SUBROUTINE test_nbit
+
+!-------------------------------------------------------------------------
+! Function: test_scaleoffset
+!
+! Purpose: Tests the integer datatype for scaleoffset filter
+! with fill value set
+!
+! Return: Success: 0
+! Failure: >0
+!
+! Programmer: M. Scot Breitenfeld
+! Decemeber 11, 2010
+!
+! Modifications:
+!
+!-------------------------------------------------------------------------
+!
+
+SUBROUTINE test_scaleoffset(cleanup, total_error )
+
+ USE HDF5
+
+ IMPLICIT NONE
+ LOGICAL, INTENT(IN) :: cleanup
+ INTEGER, INTENT(INOUT) :: total_error
+ INTEGER(hid_t) :: file
+
+ INTEGER(hid_t) :: dataset, datatype, space, mspace, dc
+ INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2, 5/)
+ INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2, 5/)
+ INTEGER, DIMENSION(1:2,1:5) :: orig_data
+ INTEGER, DIMENSION(1:2,1:5) :: new_data
+ INTEGER(hsize_t), DIMENSION(1:2) :: start ! Start of hyperslab
+ INTEGER(hsize_t), DIMENSION(1:2) :: stride ! Stride of hyperslab
+ INTEGER(hsize_t), DIMENSION(1:2) :: count ! BLOCK count
+ INTEGER(hsize_t), DIMENSION(1:2) :: BLOCK ! BLOCK sizes
+ INTEGER :: fillval
+ INTEGER(size_t) :: j
+ REAL :: x
+ INTEGER :: error
+ LOGICAL :: status
+
+ ! check to see if filter is available
+ CALL H5Zfilter_avail_f(H5Z_FILTER_SCALEOFFSET_F, status, error)
+ IF(.NOT.status)THEN ! We don't have H5Z_FILTER_SCALEOFFSET_F filter
+ total_error = -1 ! so return
+ RETURN
+ ENDIF
+
+ CALL H5Fcreate_f("h5scaleoffset.h5", H5F_ACC_TRUNC_F, file, error)
+ CALL check("H5Fcreate_f", error, total_error)
+
+ CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
+ CALL CHECK(" H5Tcopy_f", error, total_error)
+
+ ! Set order of dataset datatype
+ CALL H5Tset_order_f(datatype, H5T_ORDER_BE_F, error)
+ CALL CHECK(" H5Tset_order_f", error, total_error)
+
+ ! Create the data space for the dataset
+ CALL H5Screate_simple_f(2, dims, space, error)
+ CALL CHECK(" H5Screate_simple_f", error, total_error)
+
+ ! Create the dataset property list
+ CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error)
+ CALL CHECK(" H5Pcreate_f", error, total_error)
+
+ ! Set fill value
+ fillval = 10000
+ CALL H5Pset_fill_value_f(dc, H5T_NATIVE_INTEGER, fillval, error)
+ CALL CHECK(" H5Pset_fill_value_f", error, total_error)
+
+ ! Set up to use scaleoffset filter, let library calculate minbits
+ CALL H5Pset_chunk_f(dc, 2, chunk_dim, error)
+ CALL CHECK(" H5Pset_chunk_f", error, total_error)
+
+ CALL H5Pset_scaleoffset_f(dc, H5Z_SO_INT_F, H5Z_SO_INT_MINBITS_DEFAULT_F, error)
+ CALL CHECK(" H5Pset_scaleoffset_f", error, total_error)
+
+ ! Create the dataset
+ CALL H5Dcreate_f(file, "scaleoffset_int", datatype, &
+ space, dataset, error, dc)
+ CALL CHECK(" H5Dcreate_f", error, total_error)
+
+ ! Create the memory data space
+ CALL H5Screate_simple_f(2, dims, mspace, error)
+ CALL CHECK(" H5Screate_simple_f", error, total_error)
+
+ ! Select hyperslab for data to write, using 1x5 blocks,
+ ! (1,1) stride and (1,1) count starting at the position (0,0)
+
+ start(1:2) = (/0,0/)
+ stride(1:2) = (/1,1/)
+ COUNT(1:2) = (/1,1/)
+ BLOCK(1:2) = (/1,5/)
+
+ CALL H5Sselect_hyperslab_f(mspace, H5S_SELECT_SET_F, start, &
+ count, error, stride, BLOCK)
+ CALL CHECK(" H5Sselect_hyperslab_f", error, total_error)
+
+ CALL RANDOM_SEED()
+ ! Initialize data of hyperslab
+ DO j = 1, dims(2)
+ CALL RANDOM_NUMBER(x)
+ orig_data(1,j) = INT(x*10000.)
+ IF(MOD(j,2).EQ.0)THEN
+ orig_data(1,j) = - orig_data(1,j)
+ ENDIF
+ ENDDO
+
+ !----------------------------------------------------------------------
+ ! STEP 1: Test scaleoffset by setting up a chunked dataset and writing
+ ! to it.
+ !----------------------------------------------------------------------
+
+ ! Only data in the hyperslab will be written, other value should be fill value
+ CALL H5Dwrite_f(dataset, H5T_NATIVE_INTEGER, orig_data, dims, error, mspace, mspace, H5P_DEFAULT_F)
+ CALL CHECK(" H5Dwrite_f", error, total_error)
+
+ !----------------------------------------------------------------------
+ ! STEP 2: Try to read the data we just wrote.
+ !----------------------------------------------------------------------
+
+ ! Read the dataset back
+
+ CALL H5Dread_f(dataset, H5T_NATIVE_INTEGER, new_data, dims, error, mspace, mspace, H5P_DEFAULT_F)
+ CALL CHECK(" H5Dread_f", error, total_error)
+
+ ! Check that the values read are the same as the values written
+ DO j = 1, dims(2)
+ IF(new_data(1,j) .NE. orig_data(1,j))THEN
+ total_error = total_error + 1
+ WRITE(*,'(" Read different values than written.")')
+ WRITE(*,'(" At index ", 2(1X,I0))') 1, j
+ EXIT
+ ENDIF
+ ENDDO
+ !----------------------------------------------------------------------
+ ! Cleanup
+ !----------------------------------------------------------------------
+ CALL H5Tclose_f(datatype, error)
+ CALL CHECK(" H5Tclose_f", error, total_error)
+ CALL H5Pclose_f(dc, error)
+ CALL CHECK(" H5Pclose_f", error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL CHECK(" H5Sclose_f", error, total_error)
+ CALL H5Dclose_f(dataset, error)
+ CALL CHECK(" H5Dclose_f", error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL CHECK(" H5Fclose_f", error, total_error)
+
+END SUBROUTINE test_scaleoffset
diff --git a/fortran/test/fortranlib_test_F03.f90 b/fortran/test/fortranlib_test_F03.f90
new file mode 100644
index 0000000..62315ba
--- /dev/null
+++ b/fortran/test/fortranlib_test_F03.f90
@@ -0,0 +1,168 @@
+!****h* root/fortran/test/fortranlib_test_F03.f90
+!
+! NAME
+! fortranlib_test_F03.f90
+!
+! FUNCTION
+! Basic testing of Fortran API's requiring Fortran 2003
+! compliance.
+!
+! COPYRIGHT
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! Copyright by The HDF Group. *
+! Copyright by the Board of Trustees of the University of Illinois. *
+! All rights reserved. *
+! *
+! This file is part of HDF5. The full HDF5 copyright notice, including *
+! terms governing use, modification, and redistribution, is contained in *
+! the files COPYING and Copyright.html. COPYING can be found at the root *
+! of the source code distribution tree; Copyright.html can be found at the *
+! root level of an installed copy of the electronic HDF5 document set and *
+! is linked from the top-level documents page. It can also be found at *
+! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
+! access to either file, you may request a copy from help@hdfgroup.org. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+!*****
+
+PROGRAM fortranlibtest_F03
+
+ USE HDF5
+
+ IMPLICIT NONE
+ INTEGER :: total_error = 0
+ INTEGER :: error
+ INTEGER :: majnum, minnum, relnum
+ LOGICAL :: szip_flag
+ INTEGER :: ret_total_error
+ LOGICAL :: cleanup, status
+
+ CALL h5open_f(error)
+
+ cleanup = .TRUE.
+ CALL h5_env_nocleanup_f(status)
+ IF(status) cleanup=.FALSE.
+
+ WRITE(*,'(24X,A)') '=============================='
+ WRITE(*,'(24X,A)') ' FORTRAN 2003 tests '
+ WRITE(*,'(24X,A)') '=============================='
+ CALL h5get_libversion_f(majnum, minnum, relnum, total_error)
+ IF(total_error .EQ. 0) THEN
+ WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO")
+ WRITE(*, '(I1)', advance="NO") majnum
+ WRITE(*, '(".")', advance="NO")
+ WRITE(*, '(I1)', advance="NO") minnum
+ WRITE(*, '(" release ")', advance="NO")
+ WRITE(*, '(I3)') relnum
+ ELSE
+ total_error = total_error + 1
+ ENDIF
+
+ ret_total_error = 0
+! PROBLEMS with C
+! CALL test_error(ret_total_error)
+! CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error)
+
+ WRITE(*,*)
+! write(*,*)
+! write(*,*) '========================================='
+! write(*,*) 'Testing DATATYPE interface '
+! write(*,*) '========================================='
+ ret_total_error = 0
+ CALL test_array_compound_atomic(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Datatypes Functionality', total_error)
+
+ ret_total_error = 0
+ CALL test_array_compound_array(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Array Datatypes Functionality', total_error)
+
+ ret_total_error = 0
+ CALL t_array(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing 3-D array by dataset, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_enum(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading enum dataset, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_bit(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading bitfield dataset, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_opaque(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading opaque datatypes, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_objref(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading object references, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_regref(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading region references, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_vlen(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading variable-length datatypes, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_vlstring(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading variable-string datatypes, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL t_string(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing writing/reading string datatypes, using C_LOC', total_error)
+
+ ret_total_error = 0
+ CALL test_create(ret_total_error)
+ CALL write_test_status(ret_total_error, &
+ ' Testing filling functions', &
+ total_error)
+!DEC$ if defined(H5_VMS)
+ GOTO 8
+!DEC$ else
+ ret_total_error = 0
+ CALL file_close(cleanup, ret_total_error)
+ CALL write_test_status(ret_total_error, ' File open/close test', total_error)
+!DEC$ endif
+8 CONTINUE
+
+ ret_total_error = 0
+ CALL test_h5kind_to_type(total_error)
+ CALL write_test_status(ret_total_error, &
+ ' Test function h5kind_to_type', &
+ total_error)
+
+ ret_total_error = 0
+ CALL test_array_bkg(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing Partial I/O of Array Fields in Compound Datatype FunctionalityT', total_error)
+
+ ret_total_error = 0
+ CALL test_genprop_class_callback(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Test basic generic property list callback functionality', total_error)
+
+ ret_total_error = 0
+ CALL test_iter_group(ret_total_error)
+ CALL write_test_status(ret_total_error, ' Testing Group Iteration Functionality', total_error)
+
+! write(*,*)
+! write(*,*) '========================================='
+! write(*,*) 'Testing GROUP interface '
+! write(*,*) '========================================='
+
+
+ WRITE(*,*)
+
+ WRITE(*,*) ' ============================================ '
+ WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with '
+ WRITE(*, fmt = '(i4)', advance='NO') total_error
+ WRITE(*, fmt = '(12a)' ) ' error(s) ! '
+ WRITE(*,*) ' ============================================ '
+
+ CALL h5close_f(error)
+
+ ! if errors detected, exit with non-zero code.
+ IF (total_error .NE. 0) CALL h5_exit_f(1)
+
+END PROGRAM fortranlibtest_F03
+
+
diff --git a/fortran/test/t.c b/fortran/test/t.c
index bf30331..01d4cdd 100644
--- a/fortran/test/t.c
+++ b/fortran/test/t.c
@@ -1,4 +1,13 @@
-/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+/****h* root/fortran/test/tc.c
+ *
+ * NAME
+ * tc.c
+ *
+ * FUNCTION
+ * This file contains C routines needed for the test programs.
+ *
+ * COPYRIGHT
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* Copyright by The HDF Group. *
* Copyright by the Board of Trustees of the University of Illinois. *
* All rights reserved. *
@@ -11,7 +20,10 @@
* is linked from the top-level documents page. It can also be found at *
* http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
* access to either file, you may request a copy from help@hdfgroup.org. *
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ *
+ ******
+*/
#include "t.h"
#include "H5Eprivate.h"
diff --git a/fortran/test/tH5A.f90 b/fortran/test/tH5A.f90
index dd6cbb1..03522f7 100644
--- a/fortran/test/tH5A.f90
+++ b/fortran/test/tH5A.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5A.f90
+!
+! NAME
+! tH5A.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5A APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,12 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! attribute_test
+!
+!
+!*****
+
SUBROUTINE attribute_test(cleanup, total_error)
! This subroutine tests following functionalities:
diff --git a/fortran/test/tH5A_1_8.f90 b/fortran/test/tH5A_1_8.f90
index c48420e..c1dca9d 100644
--- a/fortran/test/tH5A_1_8.f90
+++ b/fortran/test/tH5A_1_8.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5A_1_8.f90
+!
+! NAME
+! tH5A_1_8.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5A APIs introduced in 1.8.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,15 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! attribute_test_1_8, test_attr_corder_create_compact, test_attr_null_space,
+! test_attr_create_by_name, test_attr_info_by_idx, attr_info_by_idx_check,
+! test_attr_shared_rename, test_attr_delete_by_idx, test_attr_shared_delete,
+! test_attr_dense_open, test_attr_dense_verify, test_attr_corder_create_basic,
+! test_attr_basic_write, test_attr_many, attr_open_check,
+!
+!*****
+
SUBROUTINE attribute_test_1_8(cleanup, total_error)
! This subroutine tests following 1.8 functionalities:
@@ -96,18 +114,6 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
' - Tests INT attributes on both datasets and groups', &
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
@@ -117,7 +123,6 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
WRITE(*,*) " - Testing without shared attributes:"
my_fcpl = fcpl
END IF
-!!$ CALL test_attr_dense_create(my_fcpl, my_fapl)
ret_total_error = 0
CALL test_attr_dense_open(my_fcpl, my_fapl, ret_total_error)
@@ -125,17 +130,11 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
' - Testing INT attributes on both datasets and groups', &
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)
ret_total_error = 0
CALL test_attr_null_space(my_fcpl, my_fapl, ret_total_error)
CALL write_test_status(ret_total_error, &
' - Testing storing attribute with "null" dataspace', &
total_error)
-!!$ CALL test_attr_deprec(fcpl, my_fapl)
ret_total_error = 0
CALL test_attr_many(new_format(i), my_fcpl, my_fapl, ret_total_error)
CALL write_test_status(ret_total_error, &
@@ -153,10 +152,6 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
CALL write_test_status(ret_total_error, &
' - Testing compact storage on objects with attribute creation order', &
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)
ret_total_error = 0
CALL test_attr_info_by_idx(new_format(i), my_fcpl, my_fapl, ret_total_error)
CALL write_test_status(ret_total_error, &
@@ -169,9 +164,6 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
' - Testing deleting attribute by index', &
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)
ret_total_error = 0
CALL test_attr_create_by_name(new_format(i), my_fcpl, my_fapl, ret_total_error)
CALL write_test_status(ret_total_error, &
@@ -180,7 +172,6 @@ SUBROUTINE attribute_test_1_8(cleanup, 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)
ret_total_error = 0
CALL test_attr_shared_rename(my_fcpl, my_fapl, ret_total_error)
CALL write_test_status(ret_total_error,&
@@ -193,24 +184,8 @@ SUBROUTINE attribute_test_1_8(cleanup, total_error)
' - Testing deleting shared attributes in "compact" & "dense" storage', &
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
ENDDO
@@ -315,13 +290,7 @@ SUBROUTINE test_attr_corder_create_compact(fcpl,fapl, total_error)
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
@@ -337,13 +306,6 @@ SUBROUTINE test_attr_corder_create_compact(fcpl,fapl, 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
@@ -387,14 +349,6 @@ SUBROUTINE test_attr_corder_create_compact(fcpl,fapl, total_error)
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
@@ -483,8 +437,6 @@ SUBROUTINE test_attr_null_space(fcpl, fapl, total_error)
data_dims = 0
- ! /* Output message about test being performed */
-! WRITE(*,*) " - Testing Storing Attributes with 'null' dataspace"
! /* Create file */
CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, fcpl, fapl)
CALL check("h5fcreate_f",error,total_error)
@@ -533,9 +485,6 @@ SUBROUTINE test_attr_null_space(fcpl, fapl, total_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)
@@ -639,11 +588,11 @@ SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, 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
+ 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)
@@ -691,11 +640,6 @@ SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, total_error)
! 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 */
@@ -722,15 +666,6 @@ SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, 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)
@@ -771,39 +706,8 @@ SUBROUTINE test_attr_create_by_name(new_format,fcpl,fapl, total_error)
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 */
@@ -914,13 +818,6 @@ SUBROUTINE test_attr_info_by_idx(new_format, fcpl, fapl, total_error)
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)
@@ -958,16 +855,8 @@ SUBROUTINE test_attr_info_by_idx(new_format, fcpl, fapl, total_error)
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
@@ -1005,7 +894,6 @@ SUBROUTINE test_attr_info_by_idx(new_format, fcpl, fapl, total_error)
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)
@@ -1138,7 +1026,6 @@ SUBROUTINE attr_info_by_idx_check(obj_id, attrname, n, use_index, 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)
@@ -1178,9 +1065,7 @@ SUBROUTINE attr_info_by_idx_check(obj_id, attrname, n, use_index, total_error )
f_corder_valid, corder, cset, data_size, error)
CALL check("h5aget_info_by_idx_f",error,total_error)
CALL VERIFY("h5aget_info_by_idx_f",corder,INT(n),total_error)
-!!$ ret = H5Aget_name_by_idx(obj_id, ".", H5_INDEX_NAME, H5_ITER_INC, n, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT)
-!!$ CALL CHECK(ret, FAIL, "H5Aget_name_by_idx")
-!!$ IF (HDstrcmp(attrname, tmpname)) CALL TestErrPrintf("Line %d: attribute name size wrong!\n"C, __LINE__)
+
CALL h5aget_info_by_idx_f(obj_id, ".", H5_INDEX_NAME_F, H5_ITER_DEC_F, n, &
f_corder_valid, corder, cset, data_size, error)
CALL check("h5aget_info_by_idx_f",error,total_error)
@@ -1190,9 +1075,7 @@ SUBROUTINE attr_info_by_idx_check(obj_id, attrname, n, use_index, total_error )
f_corder_valid, corder, cset, data_size, error)
CALL check("h5aget_info_by_idx_f",error,total_error)
CALL VERIFY("h5aget_info_by_idx_f",corder,INT(n),total_error)
-!!$ ret = H5Aget_name_by_idx(obj_id, ".", H5_INDEX_NAME, H5_ITER_DEC, (hsize_t)0, tmpname, (size_t)NAME_BUF_SIZE, H5P_DEFAULT)
-!!$ CALL CHECK(ret, FAIL, "H5Aget_name_by_idx")
-!!$ IF (HDstrcmp(attrname, tmpname)) CALL TestErrPrintf("Line %d: attribute name size wrong!\n"C, __LINE__)
+
END SUBROUTINE attr_info_by_idx_check
@@ -1263,9 +1146,7 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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 */
+ ! /* Initialize "big" attribute data */
! /* Create dataspace for dataset */
CALL h5screate_f(H5S_SCALAR_F, sid, error)
@@ -1338,19 +1219,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, 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)
@@ -1358,16 +1226,8 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, 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 */
-
+ ! /* Add attributes to each dataset, until after converting to dense storage */
DO u = 0, (max_compact * 2) - 1
! /* Create attribute name */
@@ -1382,10 +1242,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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
@@ -1397,15 +1253,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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
@@ -1413,24 +1260,12 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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
@@ -1439,10 +1274,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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
@@ -1456,15 +1287,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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 */
@@ -1475,23 +1297,11 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, 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
@@ -1510,22 +1320,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
CALL H5Aopen_f(dataset2, attrname2, attr, error, aapl_id=H5P_DEFAULT_F)
CALL check("H5Aopen_f",error,total_error)
-!!$
-!!$ IF(MOD(u+1,2).EQ.0)THEN
-!!$ ! /* Check that attribute is not shared */
-!!$ is_shared = H5A_is_shared_test(attr);
-!!$ CALL VERIFY("H5A_is_shared_test", error, minusone)
-!!$ ELSE
-!!$ ! /* Check that attribute is shared */
-!!$ is_shared = H5A_is_shared_test(attr);
-!!$ VERIFY(is_shared, TRUE, "H5A_is_shared_test");
-!!$
-!!$ /* Check refcount for attribute */
-!!$ ret = H5A_get_shared_rc_test(attr, &shared_refcount);
-!!$ CHECK(ret, FAIL, "H5A_get_shared_rc_test");
-!!$ VERIFY(shared_refcount, 1, "H5A_get_shared_rc_test")
-!!$ ENDIF
-
! /* Close attribute */
CALL h5aclose_f(attr, error)
CALL check("h5aclose_f",error,total_error)
@@ -1534,22 +1328,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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)
@@ -1565,22 +1343,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
! /* 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)
@@ -1592,22 +1354,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_error)
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)
@@ -1624,20 +1370,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, 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)
@@ -1651,23 +1383,6 @@ SUBROUTINE test_attr_shared_rename( fcpl, fapl, total_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)
@@ -1774,41 +1489,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
! /* 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)
@@ -1852,11 +1532,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
! CALL HDassert(0.AND."Toomanydatasets!")
END SELECT
- ! /* Check on dataset's attribute storage status */
-!!$ is_empty = H5O_is_attr_empty_test(my_dataset);
-!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test");
-!!$ is_dense = H5O_is_attr_dense_test(my_dataset);
-!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test");
! /* Check for deleting non-existant attribute */
!EP CALL H5Adelete_by_idx_f(my_dataset, '.', idx_type, order, 0_HSIZE_T,error, lapl_id=H5P_DEFAULT_F)
@@ -1887,18 +1562,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
ENDDO
-
-
- ! /* Verify state of object */
-
-!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs);
-!!$ CHECK(ret, FAIL, "H5O_num_attrs_test");
-!!$ VERIFY(nattrs, max_compact, "H5O_num_attrs_test");
-!!$ is_empty = H5O_is_attr_empty_test(my_dataset);
-!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test");
-!!$ is_dense = H5O_is_attr_dense_test(my_dataset);
-!!$ VERIFY(is_dense, FALSE, "H5O_is_attr_dense_test");
-
!/* Check for out of bound deletions */
CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error, lapl_id=H5P_DEFAULT_F)
CALL VERIFY("H5Adelete_by_idx_f",error,minusone,total_error)
@@ -1946,7 +1609,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, 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), &
@@ -1969,10 +1631,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, hzero, error)
CALL check("H5Adelete_by_idx_f",error,total_error)
-
- ! /* Verify state of attribute storage (empty) */
-!!$ is_empty = H5O_is_attr_empty_test(my_dataset);
-!!$ VERIFY(is_empty, TRUE, "H5O_is_attr_empty_test");
ENDDO
! /* Work on all the datasets */
@@ -2011,34 +1669,8 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
CALL h5aclose_f(attr, error)
CALL check("h5aclose_f",error,total_error)
- ! /* Verify state of object */
- IF(u .GE. max_compact)THEN
-!!$ is_dense = H5O_is_attr_dense_test(my_dataset);
-!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test");
- ENDIF
- ! /* Verify information for new attribute */
-!!$ CALL check("attr_info_by_idx_check",error,total_error)
ENDDO
-
- ! /* Verify state of object */
-!!$ ret = H5O_num_attrs_test(my_dataset, &nattrs);
-!!$ CHECK(ret, FAIL, "H5O_num_attrs_test");
-!!$ VERIFY(nattrs, (max_compact * 2), "H5O_num_attrs_test");
-!!$ is_empty = H5O_is_attr_empty_test(my_dataset);
-!!$ VERIFY(is_empty, FALSE, "H5O_is_attr_empty_test");
-!!$ is_dense = H5O_is_attr_dense_test(my_dataset);
-!!$ VERIFY(is_dense, (new_format ? TRUE : FALSE), "H5O_is_attr_dense_test");
-!!$
- IF(new_format)THEN
-!!$ ! /* Retrieve & verify # of records in the name & creation order indices */
-!!$ ret = H5O_attr_dense_info_test(my_dataset, &name_count, &corder_count);
-!!$ CHECK(ret, FAIL, "H5O_attr_dense_info_test");
-!!$ IF(use_index)
-!!$ VERIFY(name_count, corder_count, "H5O_attr_dense_info_test");
-!!$ VERIFY(name_count, (max_compact * 2), "H5O_attr_dense_info_test");
- ENDIF
-
! /* Check for out of bound deletion */
CALL H5Adelete_by_idx_f(my_dataset, ".", idx_type, order, INT(u,HSIZE_T), error)
CALL VERIFY("H5Adelete_by_idx_f",error,minusone,total_error)
@@ -2054,8 +1686,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
my_dataset = dset2
CASE (2)
my_dataset = dset3
- ! CASE DEFAULT
- ! CALL HDassert(0.AND."Toomanydatasets!")
END SELECT
! /* Delete attributes from dense storage */
@@ -2101,9 +1731,6 @@ SUBROUTINE test_attr_delete_by_idx(new_format, fcpl, fapl, total_error)
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)
@@ -2194,7 +1821,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
INTEGER :: arank = 1 ! Attribure rank
! /* Output message about test being performed */
-! WRITE(*,*) " - Testing Deleting Shared & Unshared Attributes in Compact & Dense Storage"
! /* Initialize "big" attribute DATA */
! /* Create dataspace for dataset */
@@ -2225,11 +1851,9 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
! /* 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)
@@ -2238,7 +1862,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
! /* Make datatypes & dataspaces > 1 byte shared (i.e. all of them :-) */
CALL H5Pset_shared_mesg_index_f(my_fcpl, 1, H5O_SHMESG_DTYPE_FLAG_F, 1,error)
CALL H5Pset_shared_mesg_index_f(my_fcpl, 2, H5O_SHMESG_SDSPACE_FLAG_F, 1,error)
-!!$ CHECK_I(ret, "H5Pset_shared_mesg_index");
ENDIF
! /* Create file */
@@ -2275,19 +1898,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, 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)
@@ -2295,13 +1905,7 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, 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
@@ -2318,10 +1922,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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
@@ -2332,16 +1932,7 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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
@@ -2349,24 +1940,12 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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
@@ -2375,10 +1954,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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
@@ -2391,15 +1966,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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 */
@@ -2408,23 +1974,11 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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 */
@@ -2439,29 +1993,9 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_error)
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)
@@ -2480,21 +2014,6 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, 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)
@@ -2509,31 +2028,11 @@ SUBROUTINE test_attr_shared_delete(fcpl, fapl, total_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 */
@@ -2587,8 +2086,6 @@ SUBROUTINE test_attr_dense_open( fcpl, fapl, total_error)
data_dims = 0
- ! /* Output message about test being performed */
-! WRITE(*,*) " - Testing Opening Attributes in Dense Storage"
! /* Create file */
@@ -2631,10 +2128,6 @@ SUBROUTINE test_attr_dense_open( fcpl, fapl, total_error)
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
@@ -2657,13 +2150,8 @@ SUBROUTINE test_attr_dense_open( fcpl, fapl, 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 */
@@ -2673,11 +2161,6 @@ SUBROUTINE test_attr_dense_open( fcpl, fapl, total_error)
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)
@@ -2990,8 +2473,6 @@ SUBROUTINE test_attr_basic_write(fapl, total_error)
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)
@@ -3056,8 +2537,6 @@ SUBROUTINE test_attr_basic_write(fapl, total_error)
CALL check("h5aget_storage_size_f",error,total_error)
!EP CALL VERIFY("h5aget_storage_size_f", INT(attr_size), 2*HSIZE_T, total_error)
-! attr_size = H5Aget_storage_size(attr);
-! VERIFY(attr_size, (ATTR1_DIM1 * sizeof(int)), "H5A_get_storage_size");
! /* Read attribute information immediately, without closing attribute */
CALL h5aread_f(attr, H5T_NATIVE_INTEGER, read_data1, dimsa, error)
@@ -3156,9 +2635,6 @@ SUBROUTINE test_attr_many(new_format, fcpl, fapl, total_error)
INTEGER(HID_T) :: sid
INTEGER(HID_T) :: gid
INTEGER(HID_T) :: aid
-
-
-
INTEGER :: error
INTEGER(HSIZE_T), DIMENSION(7) :: data_dims
@@ -3175,8 +2651,6 @@ SUBROUTINE test_attr_many(new_format, fcpl, fapl, total_error)
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)
diff --git a/fortran/test/tH5D.f90 b/fortran/test/tH5D.f90
index 56e82f4..682e242 100644
--- a/fortran/test/tH5D.f90
+++ b/fortran/test/tH5D.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5D.f90
+!
+! NAME
+! tH5D.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5D APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,14 +22,17 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! NOTES
+! Tests the H5D APIs functionalities of:
+! h5dcreate_f, h5dopen_f, h5dclose_f, h5dget_space_f, h5dget_type_f,
+! h5dread_f, and h5dwrite_f
!
!
-! Testing Dataset Interface functionality.
+! CONTAINS SUBROUTINES
+! datasettest, extenddsettest
!
-!
-! The following subroutine tests the following functionalities:
-! h5dcreate_f, h5dopen_f, h5dclose_f, h5dget_space_f, h5dget_type_f,
-! h5dread_f, and h5dwrite_f
+!*****
+
!
SUBROUTINE datasettest(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
diff --git a/fortran/test/tH5E.f90 b/fortran/test/tH5E.f90
index a4912bd..4d431a1 100644
--- a/fortran/test/tH5E.f90
+++ b/fortran/test/tH5E.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5E.f90
+!
+! NAME
+! tH5E.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5E APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,15 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! NOTES
+! Tests the H5D APIs functionalities of:
+! h5eprint_f
+!
+! CONTAINS SUBROUTINES
+! error_report_test
+!
+!*****
+!
SUBROUTINE error_report_test(cleanup, total_error)
! This subroutine tests following functionalities: h5eprint_f
diff --git a/fortran/test/tH5E_F03.f90 b/fortran/test/tH5E_F03.f90
new file mode 100644
index 0000000..75a534e
--- /dev/null
+++ b/fortran/test/tH5E_F03.f90
@@ -0,0 +1,210 @@
+!****h* root/fortran/test/tH5E_F03.f90
+!
+! NAME
+! tH5E_F03.f90
+!
+! FUNCTION
+! Test FORTRAN HDF5 H5E APIs which are dependent on FORTRAN 2003
+! features.
+!
+! COPYRIGHT
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! Copyright by The HDF Group. *
+! Copyright by the Board of Trustees of the University of Illinois. *
+! All rights reserved. *
+! *
+! This file is part of HDF5. The full HDF5 copyright notice, including *
+! terms governing use, modification, and redistribution, is contained in *
+! the files COPYING and Copyright.html. COPYING can be found at the root *
+! of the source code distribution tree; Copyright.html can be found at the *
+! root level of an installed copy of the electronic HDF5 document set and *
+! is linked from the top-level documents page. It can also be found at *
+! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
+! access to either file, you may request a copy from help@hdfgroup.org. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+! USES
+! liter_cb_mod
+!
+! CONTAINS SUBROUTINES
+! test_error
+!
+!*****
+
+! *****************************************
+! *** H 5 E T E S T S
+! *****************************************
+
+MODULE test_my_hdf5_error_handler
+
+ IMPLICIT NONE
+
+CONTAINS
+
+!/****************************************************************
+!**
+!** my_hdf5_error_handler: Custom error callback routine.
+!**
+!****************************************************************/
+
+ INTEGER FUNCTION my_hdf5_error_handler(estack_id, data_inout) bind(C)
+
+ ! This error function handle works with only version 2 error stack
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ ! estack_id is always passed from C as: H5E_DEFAULT
+ INTEGER(HID_T) :: estack_id
+ ! data that was registered with H5Eset_auto_f
+! INTEGER, DIMENSION(1:2) :: data_inout
+ INTEGER :: data_inout
+
+ PRINT*, " "
+ PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, WITH DATA"
+ PRINT*, " -This message should be written to standard out- "
+ PRINT*, " Data Values Passed In =", data_inout
+ PRINT*, " "
+
+ data_inout = 10*data_inout
+
+ my_hdf5_error_handler = 1 ! this is not used by the C routine
+
+ END FUNCTION my_hdf5_error_handler
+
+ INTEGER FUNCTION my_hdf5_error_handler_nodata(estack_id, data_inout) bind(C)
+
+ ! This error function handle works with only version 2 error stack
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ ! estack_id is always passed from C as: H5E_DEFAULT
+ INTEGER(HID_T) :: estack_id
+ ! data that was registered with H5Eset_auto_f
+ TYPE(C_PTR) :: data_inout
+
+ PRINT*, " "
+ PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, NO DATA"
+ PRINT*, " -This message should be written to standard out- "
+ PRINT*, " "
+
+ my_hdf5_error_handler_nodata = 1 ! this is not used by the C routine
+
+ END FUNCTION my_hdf5_error_handler_nodata
+
+END MODULE test_my_hdf5_error_handler
+
+SUBROUTINE test_error(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ USE test_my_hdf5_error_handler
+
+ IMPLICIT NONE
+
+ INTEGER(hid_t), PARAMETER :: FAKE_ID = -1
+ INTEGER :: total_error
+ INTEGER(hid_t) :: file
+ INTEGER(hid_t) :: dataset, space
+ INTEGER(hid_t) :: estack_id
+ INTEGER(hsize_t), DIMENSION(1:2) :: dims
+ CHARACTER(LEN=10) :: FUNC_test_error = "test_error"
+ TYPE(C_FUNPTR) :: old_func
+ TYPE(C_PTR) :: old_data, null_data
+ INTEGER :: error
+ TYPE(C_FUNPTR) :: op
+ INTEGER, DIMENSION(1:100,1:200), TARGET :: ipoints2
+ !! INTEGER, DIMENSION(1:2), TARGET :: my_hdf5_error_handler_data
+ INTEGER, DIMENSION(:), POINTER :: ptr_data
+ INTEGER, TARGET :: my_hdf5_error_handler_data
+ TYPE(C_PTR) :: f_ptr
+ TYPE(C_FUNPTR) :: func
+
+ TYPE(C_PTR), TARGET :: f_ptr1
+ TYPE(C_FUNPTR), TARGET :: func1
+
+ INTEGER, DIMENSION(1:1) :: array_shape
+ LOGICAL :: is_associated
+
+ ! my_hdf5_error_handler_data(1:2) =(/1,2/)
+ my_hdf5_error_handler_data = 99
+ CALL h5fcreate_f("terror.h5", H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f", error, total_error)
+
+ ! Create the data space
+ dims(1) = 10
+ dims(2) = 20
+ CALL H5Screate_simple_f(2, dims, space, error)
+ CALL check("h5screate_simple_f", error, total_error)
+
+ ! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK **
+
+ ! set the customized error handling routine
+ func = c_funloc(my_hdf5_error_handler)
+
+ ! set the data sent to the customized routine
+ f_ptr = c_loc(my_hdf5_error_handler_data)
+
+ ! turn on automatic printing, and use a custom error routine with input data
+ CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr)
+
+ ! Create the erring dataset
+ CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
+ CALL VERIFY("h5dcreate_f", error, -1, total_error)
+
+!!$ CALL VERIFY("H5Eset_auto_f",my_hdf5_error_handler_data(1),10, total_error)
+!!$ CALL VERIFY("H5Eset_auto_f",my_hdf5_error_handler_data(2),20, total_error)
+
+ ! Test enabling and disabling default printing
+
+ CALL H5Eget_auto_f(H5E_DEFAULT_F, func1, f_ptr1, error)
+ CALL VERIFY("H5Eget_auto_f", error, 0, total_error)
+
+ ! PRINT*,c_associated(f_ptr1)
+
+ ALLOCATE(ptr_data(1:2))
+ ptr_data = 0
+ array_shape(1) = 2
+ CALL C_F_POINTER(f_ptr1, ptr_data, array_shape)
+
+ ! ptr_data => f_ptr1(1)
+
+ ! PRINT*,ptr_data(1)
+
+!!$ if(old_data != NULL)
+!!$ TEST_ERROR;
+!!$#ifdef H5_USE_16_API
+!!$ if (old_func != (H5E_auto_t)H5Eprint)
+!!$ TEST_ERROR;
+!!$#else /* H5_USE_16_API */
+!!$ if (old_func != (H5E_auto2_t)H5Eprint2)
+!!$ TEST_ERROR;
+!!$#endif /* H5_USE_16_API */
+
+
+ ! set the customized error handling routine
+ func = c_funloc(my_hdf5_error_handler_nodata)
+ ! set the data sent to the customized routine as null
+ f_ptr = C_NULL_PTR
+ ! turn on automatic printing, and use a custom error routine with no input data
+ CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr)
+
+ CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
+ CALL VERIFY("h5dcreate_f", error, -1, total_error)
+
+
+ ! turn on automatic printing with h5eprint_f which prints an error stack in the default manner.
+
+ ! func = c_funloc(h5eprint_f)
+ ! CALL H5Eset_auto_f(0, error, H5E_DEFAULT_F, func, C_NULL_PTR)
+
+ CALL H5Eset_auto_f(0, error)
+ CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
+
+ CALL H5Eset_auto_f(1, error)
+ CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
+
+END SUBROUTINE test_error
diff --git a/fortran/test/tH5F.f90 b/fortran/test/tH5F.f90
index 4b88cb3..d8f683c 100644
--- a/fortran/test/tH5F.f90
+++ b/fortran/test/tH5F.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5F.f90
+!
+! NAME
+! tH5F.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5F APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,15 +22,15 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! mountingtest, reopentest, plisttest, file_close, file_space
!
+!*****
!
-! Testing File Interface functionality.
-!
-! In the mountingtest subroutine we create one file with a group in it,
-! and another file with a dataset. Mounting is used to
-! access the dataset from the second file as a member of a group
-! in the first file.
-!
+! In the mountingtest subroutine we create one file with a group in it,
+! and another file with a dataset. Mounting is used to
+! access the dataset from the second file as a member of a group
+! in the first file.
SUBROUTINE mountingtest(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
IMPLICIT NONE
diff --git a/fortran/test/tH5G.f90 b/fortran/test/tH5G.f90
index 300e538..6befa94 100644
--- a/fortran/test/tH5G.f90
+++ b/fortran/test/tH5G.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5G.f90
+!
+! NAME
+! tH5G.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5G APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! group_test
+!
+!*****
+
SUBROUTINE group_test(cleanup, total_error)
! This subroutine tests following functionalities:
@@ -236,6 +250,7 @@
CALL h5sclose_f(dspace_id, error)
CALL check("h5sclose_f", error, total_error)
+
if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
END SUBROUTINE group_test
diff --git a/fortran/test/tH5G_1_8.f90 b/fortran/test/tH5G_1_8.f90
index 6a2c623..fd55ba9 100644
--- a/fortran/test/tH5G_1_8.f90
+++ b/fortran/test/tH5G_1_8.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5G_1_8.f90
+!
+! NAME
+! tH5G_1_8.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5G APIs introduced in 1.8.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,12 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! group_test, group_info, timestamps, mklinks, test_move_preserves, lifecycle
+! cklinks, delete_by_idx, link_info_by_idx_check, test_lcpl, objcopy,
+! lapl_nlinks
+!
+!*****
SUBROUTINE group_test(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
@@ -1057,6 +1072,7 @@ SUBROUTINE lifecycle(cleanup, fapl2, total_error)
CALL check("h5_cleanup_f", error, total_error)
END SUBROUTINE lifecycle
+
!/*-------------------------------------------------------------------------
! * Function: cklinks
! *
@@ -1070,7 +1086,7 @@ SUBROUTINE lifecycle(cleanup, fapl2, total_error)
! * Programmer: M.S. Breitenfeld
! * April 14, 2008
! *
-! * Modifications: Modified Original C code
+! * Modifications: Modified original C code
! *
! *-------------------------------------------------------------------------
! */
@@ -1118,10 +1134,10 @@ SUBROUTINE lifecycle(cleanup, fapl2, total_error)
CALL H5Lexists_f(file,"d1",Lexists, error)
- CALL verifylogical("test_lcpl.H5Lexists", Lexists,.TRUE.,total_error)
+ CALL verifylogical("H5Lexists", Lexists,.TRUE.,total_error)
CALL H5Lexists_f(file,"grp1/hard",Lexists, error)
- CALL verifylogical("test_lcpl.H5Lexists", Lexists,.TRUE.,total_error)
+ CALL verifylogical("H5Lexists", Lexists,.TRUE.,total_error)
! /* Cleanup */
CALL H5Fclose_f(file,error)
@@ -1490,7 +1506,6 @@ SUBROUTINE link_info_by_idx_check(group_id, linkname, n, &
! *-------------------------------------------------------------------------
! */
-
SUBROUTINE test_lcpl(cleanup, fapl, total_error)
USE HDF5 ! This module contains all necessary modules
@@ -1542,13 +1557,13 @@ SUBROUTINE link_info_by_idx_check(group_id, linkname, n, &
! 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)
+ CALL check("H5Fcreate_f", error, total_error)
! /* Create and link a group with the default LCPL */
CALL H5Gcreate_f(file_id, "/group", group_id, error)
- CALL check("test_lcpl.H5Gcreate_f", error, total_error)
+ CALL check("H5Gcreate_f", error, total_error)
! /* Check that its character encoding is the default */
@@ -1561,49 +1576,54 @@ SUBROUTINE link_info_by_idx_check(group_id, linkname, n, &
! * 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)
+ CALL VERIFY("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
! /* Create and commit a datatype with the default LCPL */
CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error)
- CALL check("test_lcpl.h5tcopy_f",error,total_error)
+ CALL check("h5tcopy_f",error,total_error)
CALL h5tcommit_f(file_id, "/type", type_id, error)
- CALL check("test_lcpl.h5tcommit_f", error, total_error)
+ CALL check("h5tcommit_f", error, total_error)
CALL h5tclose_f(type_id, error)
- CALL check("test_lcpl.h5tclose_f", error, total_error)
+ CALL check("h5tclose_f", error, total_error)
! /* Check that its character encoding is the default */
CALL H5Lget_info_f(file_id, "type", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.h5tclose_f", error, total_error)
+ CALL check("h5tclose_f", error, total_error)
!/* File-wide default character encoding can not yet be set via the file
! * creation property list and is always ASCII. */
!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h --
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
!/* Create a dataspace */
CALL h5screate_simple_f(2, dims, space_id, error)
- CALL check("test_lcpl.h5screate_simple_f",error,total_error)
+ CALL check("h5screate_simple_f",error,total_error)
+ CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error)
+ CALL h5pset_chunk_f(crp_list, 2, dims, error)
+ CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error)
+ CALL h5pset_chunk_f(crp_list, 2, dims, error)
CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error)
CALL h5pset_chunk_f(crp_list, 2, dims, error)
! /* Create a dataset using the default LCPL */
CALL h5dcreate_f(file_id, "/dataset", H5T_NATIVE_INTEGER, space_id, dset_id, error, crp_list)
- CALL check("test_lcpl.h5dcreate_f", error, total_error)
+ CALL check("h5dcreate_f", error, total_error)
+
CALL h5dclose_f(dset_id, error)
- CALL check("test_lcpl.h5dclose_f", error, total_error)
+ CALL check("h5dclose_f", error, total_error)
! Reopen
CALL H5Dopen_f(file_id, "/dataset", dset_id, error)
- CALL check("test_lcpl.h5dopen_f", error, total_error)
+ CALL check("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)
+ CALL check("H5Dset_extent_f", error, total_error)
! /* Verify the dataspaces */
!
!Get dataset's dataspace handle.
@@ -1612,7 +1632,7 @@ SUBROUTINE link_info_by_idx_check(group_id, linkname, n, &
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)
+ CALL check("h5sget_simple_extent_dims_f",error, total_error)
DO i = 1, 2
tmp1 = dimsout(i)
@@ -1628,170 +1648,170 @@ SUBROUTINE link_info_by_idx_check(group_id, linkname, n, &
! /* close data set */
CALL h5dclose_f(dset_id, error)
- CALL check("test_lcpl.h5dclose_f", error, total_error)
+ CALL check("h5dclose_f", error, total_error)
! /* Check that its character encoding is the default */
CALL H5Lget_info_f(file_id, "dataset", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
+ CALL check("H5Lget_info_f", error, total_error)
!/* File-wide default character encoding can not yet be set via the file
! * creation property list and is always ASCII. */
!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h --
- CALL verify("test_lcpl.h5tclose_f",cset, H5T_CSET_ASCII_F,total_error)
+ CALL verify("h5tclose_f",cset, H5T_CSET_ASCII_F,total_error)
!/* Create a link creation property list with the UTF-8 character encoding */
CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error)
- CALL check("test_lcpl.h5Pcreate_f",error,total_error)
+ CALL check("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)
+ CALL check("H5Pset_char_encoding_f",error, total_error)
! /* Create and link a group with the new LCPL */
CALL H5Gcreate_f(file_id, "/group2", group_id, error,lcpl_id=lcpl_id)
- CALL check("test_lcpl.test_lcpl.H5Gcreate_f", error, total_error)
+ CALL check("H5Gcreate_f", error, total_error)
CALL H5Gclose_f(group_id, error)
- CALL check("test_lcpl.test_lcpl.H5Gclose_f", error, total_error)
+ CALL check("H5Gclose_f", error, total_error)
!/* Check that its character encoding is UTF-8 */
CALL H5Lget_info_f(file_id, "group2", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
! /* Create and commit a datatype with the new LCPL */
CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error)
- CALL check("test_lcpl.h5tcopy_f",error,total_error)
+ CALL check("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 check("h5tcommit_f", error, total_error)
CALL h5tclose_f(type_id, error)
- CALL check("test_lcpl.h5tclose_f", error, total_error)
+ CALL check("h5tclose_f", error, total_error)
!/* Check that its character encoding is UTF-8 */
CALL H5Lget_info_f(file_id, "type2", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
! /* Create a dataset using the new LCPL */
CALL h5dcreate_f(file_id, "/dataset2", H5T_NATIVE_INTEGER, space_id, dset_id, error,lcpl_id=lcpl_id)
- CALL check("test_lcpl.h5dcreate_f", error, total_error)
+ CALL check("h5dcreate_f", error, total_error)
CALL h5dclose_f(dset_id, error)
- CALL check("test_lcpl.h5dclose_f", error, total_error)
+ CALL check("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)
+ CALL check("H5Pget_char_encoding_f", error, total_error)
+ CALL VERIFY("H5Pget_char_encoding_f", encoding, H5T_CSET_UTF8_F, total_error)
! /* Check that its character encoding is UTF-8 */
CALL H5Lget_info_f(file_id, "dataset2", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f2",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f2",cset, H5T_CSET_UTF8_F,total_error)
! /* Create a new link to the dataset with a different character encoding. */
CALL H5Pclose_f(lcpl_id, error)
- CALL check("test_lcpl.H5Pclose_f", error, total_error)
+ CALL check("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 check("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 check("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 check("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)
+ CALL check("H5Lexists",error, total_error)
+ CALL verifylogical("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)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
! /* Check that the first link's encoding hasn't changed */
CALL H5Lget_info_f(file_id, "/dataset2", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f3",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f3",cset, H5T_CSET_UTF8_F,total_error)
!/* Make sure that LCPLs work properly for other API calls: */
!/* H5Lcreate_soft */
CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error)
- CALL check("test_lcpl.H5Pset_char_encoding_f",error, total_error)
+ CALL check("H5Pset_char_encoding_f",error, total_error)
CALL H5Lcreate_soft_f("dataset2", file_id, "slink_to_dset2",error,lcpl_id)
CALL check("H5Lcreate_soft_f", error, total_error)
CALL H5Lget_info_f(file_id, "slink_to_dset2", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
! /* H5Lmove */
CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error)
- CALL check("test_lcpl.H5Pset_char_encoding_f",error, total_error)
+ CALL check("H5Pset_char_encoding_f",error, total_error)
CALL H5Lmove_f(file_id, "slink_to_dset2", file_id, "moved_slink", error, lcpl_id, H5P_DEFAULT_F)
- CALL check("test_lcpl.H5Lmove_f",error, total_error)
+ CALL check("H5Lmove_f",error, total_error)
CALL H5Lget_info_f(file_id, "moved_slink", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error)
! /* H5Lcopy */
CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error)
- CALL check("test_lcpl.H5Pset_char_encoding_f",error, total_error)
+ CALL check("H5Pset_char_encoding_f",error, total_error)
CALL H5Lcopy_f(file_id, "moved_slink", file_id, "copied_slink", error, lcpl_id)
CALL H5Lget_info_f(file_id, "copied_slink", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
! /* H5Lcreate_external */
- CALL H5Lcreate_external_f("test_lcpl.filename", "path", file_id, "extlink", error, lcpl_id)
- CALL check("test_lcpl.H5Lcreate_external_f", error, total_error)
+ CALL H5Lcreate_external_f("filename", "path", file_id, "extlink", error, lcpl_id)
+ CALL check("H5Lcreate_external_f", error, total_error)
CALL H5Lget_info_f(file_id, "extlink", &
cset, corder, f_corder_valid, link_type, address, val_size, &
error)
- CALL check("test_lcpl.H5Lget_info_f", error, total_error)
- CALL verify("test_lcpl.H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
+ CALL check("H5Lget_info_f", error, total_error)
+ CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error)
! /* Close open IDs */
CALL H5Pclose_f(lcpl_id, error)
- CALL check("test_lcpl.H5Pclose_f", error, total_error)
+ CALL check("H5Pclose_f", error, total_error)
CALL H5Sclose_f(space_id, error)
- CALL check("test_lcpl.h5Sclose_f",error,total_error)
+ CALL check("h5Sclose_f",error,total_error)
CALL H5Fclose_f(file_id, error)
- CALL check("test_lcpl.H5Fclose_f", error, total_error)
+ CALL check("H5Fclose_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f("tempfile", H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
diff --git a/fortran/test/tH5I.f90 b/fortran/test/tH5I.f90
index 0d1a8c5..184edaf 100644
--- a/fortran/test/tH5I.f90
+++ b/fortran/test/tH5I.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5I.f90
+!
+! NAME
+! tH5I.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5I APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! identifier_test
+!
+!*****
+
SUBROUTINE identifier_test(cleanup, total_error)
! This subroutine tests following functionalities: h5iget_type_f
@@ -69,21 +83,21 @@
! check that the ID is not valid
dtype = -1
CALL H5Iis_valid_f(dtype, tri_ret, error)
- CALL check("H5Iis_valid_f", error, total_error)
+ CALL check("H5Iis_valid_f", error, total_error)
CALL VerifyLogical("H5Iis_valid_f", tri_ret, .FALSE., total_error)
-
+
! Create a datatype id
CALL H5Tcopy_f(H5T_NATIVE_INTEGER,dtype,error)
- CALL check("H5Tcopy_f", error, total_error)
-
+ CALL check("H5Tcopy_f", error, total_error)
+
! Check that the ID is valid
CALL H5Iis_valid_f(dtype, tri_ret, error)
- CALL check("H5Iis_valid_f", error, total_error)
+ CALL check("H5Iis_valid_f", error, total_error)
CALL VerifyLogical("H5Tequal_f", tri_ret, .TRUE., total_error)
-
+
CALL H5Tclose_f(dtype, error)
- CALL check("H5Tclose_f", error, total_error)
-
+ CALL check("H5Tclose_f", error, total_error)
+
!
! Create a new file using default properties.
!
diff --git a/fortran/test/tH5L_F03.f90 b/fortran/test/tH5L_F03.f90
new file mode 100644
index 0000000..616734d
--- /dev/null
+++ b/fortran/test/tH5L_F03.f90
@@ -0,0 +1,334 @@
+!****h* root/fortran/test/tH5L_F03.f90
+!
+! NAME
+! tH5L_F03.f90
+!
+! FUNCTION
+! Test FORTRAN HDF5 H5L APIs which are dependent on FORTRAN 2003
+! features.
+!
+! COPYRIGHT
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! Copyright by The HDF Group. *
+! Copyright by the Board of Trustees of the University of Illinois. *
+! All rights reserved. *
+! *
+! This file is part of HDF5. The full HDF5 copyright notice, including *
+! terms governing use, modification, and redistribution, is contained in *
+! the files COPYING and Copyright.html. COPYING can be found at the root *
+! of the source code distribution tree; Copyright.html can be found at the *
+! root level of an installed copy of the electronic HDF5 document set and *
+! is linked from the top-level documents page. It can also be found at *
+! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
+! access to either file, you may request a copy from help@hdfgroup.org. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+! USES
+! liter_cb_mod
+!
+! CONTAINS SUBROUTINES
+! test_iter_group
+!
+!*****
+
+MODULE liter_cb_mod
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ TYPE iter_enum
+ INTEGER RET_ZERO
+ INTEGER RET_TWO
+ INTEGER RET_CHANGE
+ INTEGER RET_CHANGE2
+ END TYPE iter_enum
+
+ ! Custom group iteration callback data
+ TYPE, bind(c) :: iter_info
+ CHARACTER(LEN=1), DIMENSION(1:10) :: name ! The name of the object
+ INTEGER(c_int) :: TYPE ! The TYPE of the object
+ INTEGER(c_int) :: command ! The TYPE of RETURN value
+ END TYPE iter_info
+
+ TYPE, bind(c) :: union_t
+ INTEGER(haddr_t) :: address
+ INTEGER(size_t) :: val_size
+ END TYPE union_t
+
+ TYPE, bind(c) :: H5L_info_t
+ INTEGER(c_int) :: TYPE ! H5L_type_t type
+! LOGICAL(c_bool) :: corder_valid ! hbool_t corder_valid
+ INTEGER(c_int64_t) :: corder ! int64_t corder;
+ INTEGER(c_int) :: cset ! H5T_cset_t cset;
+ TYPE(union_t) :: u
+ END TYPE H5L_info_t
+
+CONTAINS
+
+!***************************************************************
+!**
+!** liter_cb(): Custom link iteration callback routine.
+!**
+!***************************************************************
+
+ INTEGER FUNCTION liter_cb(group, name, link_info, op_data) bind(C)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER(HID_T), VALUE :: group
+ CHARACTER(LEN=1), DIMENSION(1:10) :: name
+
+
+ TYPE (H5L_info_t) :: link_info
+
+ TYPE(iter_info) :: op_data
+
+ INTEGER, SAVE :: count
+ INTEGER, SAVE :: count2
+
+!!$
+!!$ iter_info *info = (iter_info *)op_data;
+!!$ static int count = 0;
+!!$ static int count2 = 0;
+
+ op_data%name(1:10) = name(1:10)
+
+ SELECT CASE (op_data%command)
+
+ CASE(0)
+ liter_cb = 0
+ CASE(2)
+ liter_cb = 2
+ CASE(3)
+ count = count + 1
+ IF(count.GT.10) THEN
+ liter_cb = 1
+ ELSE
+ liter_cb = 0
+ ENDIF
+ CASE(4)
+ count2 = count2 + 1
+ IF(count2.GT.10) THEN
+ liter_cb = 1
+ ELSE
+ liter_cb = 0
+ ENDIF
+ END SELECT
+
+ END FUNCTION liter_cb
+END MODULE liter_cb_mod
+
+! *****************************************
+! *** H 5 L T E S T S
+! *****************************************
+
+
+!***************************************************************
+!**
+!** test_iter_group(): Test group iteration functionality
+!**
+!***************************************************************
+SUBROUTINE test_iter_group(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ USE liter_cb_mod
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ INTEGER(HID_T) :: fapl
+ INTEGER(HID_T) :: file ! File ID
+ INTEGER(hid_t) :: dataset ! Dataset ID
+ INTEGER(hid_t) :: datatype ! Common datatype ID
+ INTEGER(hid_t) :: filespace ! Common dataspace ID
+ INTEGER(hid_t) :: root_group,grp ! Root group ID
+ INTEGER i,j ! counting variable
+ INTEGER(hsize_t) idx ! Index in the group
+ CHARACTER(LEN=11) :: DATAFILE = "titerate.h5"
+ INTEGER, PARAMETER :: ndatasets = 50
+ CHARACTER(LEN=10) :: name ! temporary name buffer
+ CHARACTER(LEN=10), DIMENSION(1:ndatasets+2) :: lnames ! Names of the links created
+!!$ char dataset_name[NAMELEN]; dataset name
+
+ TYPE(iter_info), TARGET :: info
+
+!!$ iter_info info; Custom iteration information
+!!$ H5G_info_t ginfo; Buffer for querying object's info
+!!$ herr_t ret; Generic return value
+
+ INTEGER :: error
+ INTEGER :: ret_value
+ TYPE(C_PTR) :: f_ptr
+ TYPE(C_FUNPTR) :: f1
+ TYPE(C_PTR) :: f2
+ CHARACTER(LEN=2) :: ichr2
+ CHARACTER(LEN=10) :: ichr10
+
+ ! Get the default FAPL
+ CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
+ CALL check("h5pcreate_f", error, total_error)
+
+ ! Set the "use the latest version of the format" bounds for creating objects in the file
+ CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error)
+ CALL check("H5Pset_libver_bounds_f",error, total_error)
+
+ ! Create the test file with the datasets
+ CALL h5fcreate_f(DATAFILE, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl)
+ CALL check("h5fcreate_f", error, total_error)
+
+ ! Test iterating over empty group
+ idx = 0
+ info%command = 0
+ f1 = C_FUNLOC(liter_cb)
+ f2 = C_LOC(info)
+
+
+ CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
+ CALL check("H5Literate_f", error, total_error)
+
+ CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
+ CALL check("H5Tcopy_f", error, total_error)
+
+ CALL H5Screate_f(H5S_SCALAR_F, filespace, error)
+ CALL check("H5Screate_f", error, total_error)
+
+ DO i = 1, ndatasets
+ WRITE(ichr2, '(I2.2)') i
+
+ name = 'Dataset '//ichr2
+
+ CALL h5dcreate_f(file, name, datatype, filespace, dataset, error)
+ CALL check("H5dcreate_f", error, total_error)
+
+ lnames(i) = name
+
+ CALL h5dclose_f(dataset,error)
+ CALL check("H5dclose_f", error, total_error)
+
+ ENDDO
+
+ ! Create a group and named datatype under root group for testing
+
+ CALL H5Gcreate_f(file, "grp0000000", grp, error)
+ CALL check("H5Gcreate_f", error, total_error)
+
+ lnames(ndatasets+2) = "grp0000000"
+
+!!$
+!!$ lnames[NDATASETS] = HDstrdup("grp");
+!!$ CHECK(lnames[NDATASETS], NULL, "strdup");
+!!$
+
+ CALL H5Tcommit_f(file, "dtype00000", datatype, error)
+ CALL check("H5Tcommit_f", error, total_error)
+
+ lnames(ndatasets+1) = "dtype00000"
+
+ ! Close everything up
+
+ CALL H5Tclose_f(datatype, error)
+ CALL check("H5Tclose_f", error, total_error)
+
+ CALL H5Gclose_f(grp, error)
+ CALL check("H5Gclose_f", error, total_error)
+
+ CALL H5Sclose_f(filespace, error)
+ CALL check("H5Sclose_f", error, total_error)
+
+ CALL H5Fclose_f(file, error)
+ CALL check("H5Fclose_f", error, total_error)
+
+ ! Iterate through the datasets in the root group in various ways
+ CALL H5Fopen_f(DATAFILE, H5F_ACC_RDONLY_F, file, error, access_prp=fapl)
+ CALL check("h5fopen_f", error, total_error)
+
+ ! Test all objects in group, when callback always returns 0
+ info%command = 0
+ idx = 0
+ CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
+ IF(ret_value.GT.0)THEN
+ PRINT*,"ERROR: Group iteration function didn't return zero correctly!"
+ CALL verify("H5Literate_f", error, -1, total_error)
+ ENDIF
+
+ ! Test all objects in group, when callback always returns 1
+ ! This also tests the "restarting" ability, because the index changes
+
+ info%command = 2
+ idx = 0
+ i = 0
+ f1 = C_FUNLOC(liter_cb)
+ f2 = C_LOC(info)
+ DO
+ CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
+ IF(error.LT.0) EXIT
+ ! Verify return value from iterator gets propagated correctly
+ CALL VERIFY("H5Literate", ret_value, 2, total_error)
+ ! Increment the number of times "2" is returned
+ i = i + 1
+ ! Verify that the index is the correct value
+ CALL VERIFY("H5Literate", INT(idx), INT(i), total_error)
+ IF(idx .GT.ndatasets+2)THEN
+ PRINT*,"ERROR: Group iteration function walked too far!"
+ ENDIF
+
+ ! Verify the correct name is retrieved
+ DO j = 1, 10
+ ichr10(j:j) = info%name(j)(1:1)
+ ENDDO
+ CALL verifystring("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
+ IF(i.EQ.52)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIXME- scot
+ END DO
+
+ ! put check if did not walk far enough -scot FIXME
+
+ IF(i .NE. (NDATASETS + 2)) THEN
+ CALL VERIFY("H5Literate_f", i, INT(NDATASETS + 2), total_error)
+ PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly"
+ ENDIF
+
+ ! Test all objects in group, when callback changes return value
+ ! This also tests the "restarting" ability, because the index changes
+
+ info%command = 3
+ idx = 0
+ i = 0
+
+ f1 = C_FUNLOC(liter_cb)
+ f2 = C_LOC(info)
+ DO
+
+ CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
+ IF(error.LT.0) EXIT
+ CALL VERIFY("H5Literate_f", ret_value, 1, total_error)
+
+ ! Increment the number of times "1" is returned
+ i = i + 1
+
+ ! Verify that the index is the correct value
+ CALL VERIFY("H5Literate_f", INT(idx), INT(i+10), total_error)
+
+ IF(idx .GT.ndatasets+2)THEN
+ PRINT*,"Group iteration function walked too far!"
+ ENDIF
+
+ DO j = 1, 10
+ ichr10(j:j) = info%name(j)(1:1)
+ ENDDO
+ ! Verify that the correct name is retrieved
+ CALL verifystring("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
+ IF(i.EQ.42)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIX- scot
+ ENDDO
+
+ IF(i .NE. 42 .OR. idx .NE. 52)THEN
+ PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly!"
+ CALL check("H5Literate_f",-1,total_error)
+ ENDIF
+
+ CALL H5Fclose_f(file, error)
+ CALL check("H5Fclose_f", error, total_error)
+
+END SUBROUTINE test_iter_group
diff --git a/fortran/test/tH5O.f90 b/fortran/test/tH5O.f90
index 253a42a..d871e59 100644
--- a/fortran/test/tH5O.f90
+++ b/fortran/test/tH5O.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5O.f90
+!
+! NAME
+! tH5O.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5O APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! test_h5o, test_h5o_link, test_h5o_plist
+!
+!*****
+
SUBROUTINE test_h5o(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
diff --git a/fortran/test/tH5P.f90 b/fortran/test/tH5P.f90
index 6a49f72..3faaac2 100644
--- a/fortran/test/tH5P.f90
+++ b/fortran/test/tH5P.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5P.f90
+!
+! NAME
+! tH5P.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5P APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! external_test, multi_file_test
+!
+!*****
+
SUBROUTINE external_test(cleanup, total_error)
! This subroutine tests following functionalities:
@@ -231,7 +245,8 @@
!
CALL h5pget_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, &
rdcc_w0, error)
- CALL check("h5pget_cache_f", error, total_error)
+ CALL check("h5pget_cache_f", error, total_error)
+
! Set cache to some number
!
@@ -239,7 +254,6 @@
CALL h5pset_cache_f(fapl, mdc_nelmts, rdcc_nelmts, rdcc_nbytes, &
rdcc_w0, error)
CALL check("h5pset_cache_f", error, total_error)
-
CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error, access_prp = fapl)
CALL check("h5fcreate_f", error, total_error)
if(error .ne. 0) then
@@ -249,7 +263,6 @@
return
endif
-
!
! Create the dataspace.
!
@@ -377,7 +390,7 @@
CALL check("h5pclose_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
-
+
IF(cleanup) CALL h5_cleanup_f(filename//'.h5-b', H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f(filename//'.h5-g', H5P_DEFAULT_F, error)
@@ -390,7 +403,7 @@
CALL check("h5_cleanup_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f(filename//'.h5-s', H5P_DEFAULT_F, error)
CALL check("h5_cleanup_f", error, total_error)
-
+
RETURN
END SUBROUTINE multi_file_test
@@ -412,14 +425,14 @@
! April 16, 2009
!-------------------------------------------------------------------------
!
-SUBROUTINE test_chunk_cache(cleanup, total_error)
-
- USE HDF5 ! This module contains all necessary modules
+SUBROUTINE test_chunk_cache(cleanup, total_error)
+ USE HDF5 ! This module contains all necessary modules
+
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(OUT) :: total_error
-
+
CHARACTER(LEN=14), PARAMETER :: filename="chunk_cache"
CHARACTER(LEN=80) :: fix_filename
INTEGER(hid_t) :: fid = -1 ! /* File ID */
@@ -457,7 +470,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
! Verify that H5Pget_chunk_cache(dapl) returns the same values as are in
! the default fapl.
- !
+ !
CALL H5Pget_cache_f(fapl_def, mdc_nelmts, nslots_1, nbytes_1, w0_1, error)
CALL check("H5Pget_cache_f", error, total_error)
CALL H5Pget_chunk_cache_f(dapl1, nslots_4, nbytes_4, w0_4, error)
@@ -514,7 +527,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
! /* Create dataset with default dapl */
CALL H5Dcreate_f(fid, "dset", H5T_NATIVE_INTEGER, sid, dsid, error, dcpl, H5P_DEFAULT_F, dapl1)
CALL check("H5Pcreate_f", error, total_error)
-
+
! /* Retrieve dapl from dataset, verify cache values are the same as on fapl_local */
CALL H5Dget_access_plist_f(dsid, dapl2, error)
CALL check("H5Dget_access_plist_f", error, total_error)
@@ -526,7 +539,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error)
ENDIF
CALL H5Pclose_f(dapl2,error); CALL check("H5Pclose_f", error, total_error)
-
+
! Set new values on dapl1. nbytes will be set to default, so the file
! property will override this setting
@@ -601,7 +614,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
CALL check("H5Pset_cache_f", error, total_error)
! Close and reopen file with new fapl_local
-
+
CALL H5Dclose_f(dsid, error); CALL check("H5Dclose_f", error, total_error)
CALL H5Fclose_f(fid,error); CALL check("h5fclose_f", error, total_error)
@@ -611,12 +624,12 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
! Verify that dapl2 retrieved earlier (using values from the old fapl)
! sets its values in the new file (test use of H5Dopen2 with a dapl)
!
-
+
CALL h5dopen_f (fid, "dset", dsid, error, dapl2)
CALL check("h5dopen_f", error, total_error)
-
+
CALL H5Pclose_f(dapl2,error); CALL check("H5Pclose_f", error, total_error) ! Close dapl2, to avoid id leak
-
+
CALL H5Dget_access_plist_f(dsid, dapl2, error)
CALL check("H5Dget_access_plist_f", error, total_error)
CALL H5Pget_chunk_cache_f(dapl2, nslots_4, nbytes_4, w0_4, error)
@@ -654,11 +667,11 @@ SUBROUTINE test_chunk_cache(cleanup, total_error)
CALL H5Dclose_f(dsid, error); CALL check("H5Dclose_f", error, total_error)
CALL H5Sclose_f(sid,error); CALL check("H5Sclose_f", error, total_error)
- CALL H5Pclose_f(fapl_local,error); CALL check("H5Pclose_f", error, total_error)
- CALL H5Pclose_f(fapl_def,error); CALL check("H5Pclose_f", error, total_error)
- CALL H5Pclose_f(dapl1,error); CALL check("H5Pclose_f", error, total_error)
- CALL H5Pclose_f(dapl2,error); CALL check("H5Pclose_f", error, total_error)
- CALL H5Pclose_f(dcpl,error); CALL check("H5Pclose_f", error, total_error)
+ CALL H5Pclose_f(fapl_local,error); CALL check("H5Pclose_f", error, total_error)
+ CALL H5Pclose_f(fapl_def,error); CALL check("H5Pclose_f", error, total_error)
+ CALL H5Pclose_f(dapl1,error); CALL check("H5Pclose_f", error, total_error)
+ CALL H5Pclose_f(dapl2,error); CALL check("H5Pclose_f", error, total_error)
+ CALL H5Pclose_f(dcpl,error); CALL check("H5Pclose_f", error, total_error)
CALL H5Fclose_f(fid,error); CALL check("H5Fclose_f", error, total_error)
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
diff --git a/fortran/test/tH5P_F03.f90 b/fortran/test/tH5P_F03.f90
new file mode 100644
index 0000000..c910869
--- /dev/null
+++ b/fortran/test/tH5P_F03.f90
@@ -0,0 +1,364 @@
+!****h* root/fortran/test/tH5P_F03.f90
+!
+! NAME
+! tH5P_F03.f90
+!
+! FUNCTION
+! Test FORTRAN HDF5 H5P APIs which are dependent on FORTRAN 2003
+! features.
+!
+! COPYRIGHT
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! Copyright by The HDF Group. *
+! Copyright by the Board of Trustees of the University of Illinois. *
+! All rights reserved. *
+! *
+! This file is part of HDF5. The full HDF5 copyright notice, including *
+! terms governing use, modification, and redistribution, is contained in *
+! the files COPYING and Copyright.html. COPYING can be found at the root *
+! of the source code distribution tree; Copyright.html can be found at the *
+! root level of an installed copy of the electronic HDF5 document set and *
+! is linked from the top-level documents page. It can also be found at *
+! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
+! access to either file, you may request a copy from help@hdfgroup.org. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+! USES
+! test_genprop_cls_cb1_mod
+!
+! CONTAINS SUBROUTINES
+! test_create, test_genprop_class_callback
+!
+!*****
+
+! *****************************************
+! *** H 5 P T E S T S
+! *****************************************
+
+MODULE test_genprop_cls_cb1_mod
+
+ ! Callback subroutine for test_genprop_class_callback
+ ! and the function H5Pcreate_class_f.
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ TYPE, bind(C) :: cop_cb_struct_ ! /* Struct for iterations */
+ INTEGER :: count
+ INTEGER(HID_T) :: id
+ END TYPE cop_cb_struct_
+
+CONTAINS
+
+ INTEGER FUNCTION test_genprop_cls_cb1_f(list_id, create_data ) bind(C)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER(HID_T), INTENT(IN), VALUE :: list_id
+
+ TYPE(cop_cb_struct_) :: create_data
+
+ create_data%count = create_data%count + 1
+ create_data%id = list_id
+
+ test_genprop_cls_cb1_f = 0
+
+ END FUNCTION test_genprop_cls_cb1_f
+
+END MODULE test_genprop_cls_cb1_mod
+
+!/*-------------------------------------------------------------------------
+! * Function: test_create
+! *
+! * Purpose: Tests H5Pset_fill_value_f and H5Pget_fill_value_f
+! *
+! * Return: Success: 0
+! *
+! * Failure: number of errors
+! *
+! * Programmer: M. Scot Breitenfeld
+! * June 24, 2008
+! *
+! * Modifications:
+! *
+! *-------------------------------------------------------------------------
+! */
+
+SUBROUTINE test_create(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ INTEGER(HID_T) :: fapl
+
+ INTEGER(hid_t) :: file=-1, space=-1, dcpl=-1, comp_type_id=-1
+ INTEGER(hid_t) :: dset1=-1, dset2=-1, dset3=-1, dset4=-1, dset5=-1, &
+ dset6=-1, dset7=-1, dset8=-1, dset9=-1
+ INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: cur_size = (/2, 8, 8, 4, 2/)
+ INTEGER(hsize_t), DIMENSION(1:5), PARAMETER :: ch_size= (/1, 1, 1, 4, 1/)
+ CHARACTER(LEN=14) :: filename ='test_create.h5'
+
+ ! /* compound datatype operations */
+ TYPE, BIND(C) :: comp_datatype
+ REAL :: a
+ INTEGER :: x
+ DOUBLE PRECISION :: y
+ CHARACTER(LEN=1) :: z
+ END TYPE comp_datatype
+
+ TYPE(comp_datatype), TARGET :: rd_c, fill_ctype
+
+ INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
+ INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
+ INTEGER(SIZE_T) :: type_sized ! Size of the double datatype
+ INTEGER(SIZE_T) :: type_sizec ! Size of the double datatype
+ INTEGER(SIZE_T) :: sizeof_compound ! total size of compound
+ INTEGER :: error
+ INTEGER(SIZE_T) :: h5off
+ TYPE(C_PTR) :: f_ptr
+
+ !/*
+ ! * Create a file.
+ ! */
+ CALL h5fcreate_f(filename,H5F_ACC_TRUNC_F,file,error)
+ CALL check("h5fcreate_f", error, total_error)
+
+ CALL h5screate_simple_f(5, cur_size, space, error, cur_size)
+ CALL check("h5screate_simple_f", error, total_error)
+
+ CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, error)
+ CALL check("H5Pcreate_f", error, total_error)
+
+ CALL h5pset_chunk_f(dcpl, 5, ch_size, error)
+ CALL check("h5pset_chunk_f",error, total_error)
+
+ ! /* Create a compound datatype */
+
+ CALL h5tcreate_f(H5T_COMPOUND_F, INT(SIZEOF(fill_ctype),size_t), comp_type_id, error)
+ CALL check("h5tcreate_f", error, total_error)
+ h5off = H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%a))
+ CALL h5tinsert_f(comp_type_id, "a", h5off , H5T_NATIVE_REAL, error)
+ CALL check("h5tinsert_f", error, total_error)
+ CALL h5tinsert_f(comp_type_id, "x", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%x)), H5T_NATIVE_INTEGER, error)
+ CALL check("h5tinsert_f", error, total_error)
+ CALL h5tinsert_f(comp_type_id, "y", H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%y)), H5T_NATIVE_DOUBLE, error)
+ CALL check("h5tinsert_f", error, total_error)
+ CALL h5tinsert_f(comp_type_id, "z", &
+ H5OFFSETOF(C_LOC(fill_ctype), C_LOC(fill_ctype%z)), H5T_NATIVE_CHARACTER, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+
+ CALL H5Pset_alloc_time_f(dcpl, H5D_ALLOC_TIME_LATE_F,error)
+ CALL check("H5Pset_alloc_time_f",error, total_error)
+
+ CALL H5Pset_fill_time_f(dcpl, H5D_FILL_TIME_ALLOC_F, error)
+ CALL check("H5Pset_fill_time_f",error, total_error)
+
+ ! /* Compound datatype test */
+
+ f_ptr = C_LOC(fill_ctype)
+
+ CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error)
+ CALL check("H5Pget_fill_value_f",error, total_error)
+
+ fill_ctype%y = 4444.
+ fill_ctype%z = 'S'
+ fill_ctype%a = 5555.
+ fill_ctype%x = 55
+
+ f_ptr = C_LOC(fill_ctype)
+
+ CALL H5Pset_fill_value_f(dcpl, comp_type_id, f_ptr, error)
+ CALL check("H5Pget_fill_value_f",error, total_error)
+
+ CALL h5dcreate_f(file,"dset9", comp_type_id, space, dset9, error, dcpl_id=dcpl)
+ CALL check("h5dcreate_f", error, total_error)
+
+ CALL h5dclose_f(dset9, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ CALL h5fclose_f(file,error)
+ CALL check("h5fclose_f", error, total_error)
+
+ ! /* Open the file and get the dataset fill value from each dataset */
+ CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
+ CALL check("H5Pcreate_f",error, total_error)
+
+ CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error)
+ CALL check("H5Pset_libver_bounds_f",error, total_error)
+
+ CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, file, error, fapl)
+ CALL check("h5fopen_f", error, total_error)
+
+ !/* Compound datatype test */
+ CALL h5dopen_f(file, "dset9", dset9, error)
+ CALL check("h5dopen_f", error, total_error)
+
+ CALL H5Dget_create_plist_f(dset9, dcpl, error)
+ CALL check("H5Dget_create_plist_f", error, total_error)
+
+ f_ptr = C_LOC(rd_c)
+
+ CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error)
+ CALL check("H5Pget_fill_value_f", error, total_error)
+
+ IF( rd_c%a .NE. fill_ctype%a .OR. &
+ rd_c%y .NE. fill_ctype%y .OR. &
+ rd_c%x .NE. fill_ctype%x .OR. &
+ rd_c%z .NE. fill_ctype%z )THEN
+
+ PRINT*,"***ERROR: Returned wrong fill value"
+ total_error = total_error + 1
+
+ ENDIF
+
+ CALL h5dclose_f(dset9, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ CALL H5Pclose_f(dcpl, error)
+ CALL check("H5Pclose_f", error, total_error)
+
+ CALL h5fclose_f(file,error)
+ CALL check("h5fclose_f", error, total_error)
+
+END SUBROUTINE test_create
+
+
+SUBROUTINE test_genprop_class_callback(total_error)
+
+ !/****************************************************************
+ !**
+ !** test_genprop_class_callback(): Test basic generic property list code.
+ !** Tests callbacks for property lists in a generic class.
+ !**
+ !** FORTRAN TESTS:
+ !** Tests function H5Pcreate_class_f with callback.
+ !**
+ !****************************************************************/
+
+ USE HDF5
+ USE ISO_C_BINDING
+ USE test_genprop_cls_cb1_mod
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ INTEGER(hid_t) :: cid1 !/* Generic Property class ID */
+ INTEGER(hid_t) :: lid1 !/* Generic Property list ID */
+ INTEGER(hid_t) :: lid2 !/* 2nd Generic Property list ID */
+ INTEGER(size_t) :: nprops !/* Number of properties in class */
+
+ TYPE cb_struct
+ INTEGER :: count
+ INTEGER(hid_t) :: id
+ END TYPE cb_struct
+
+ TYPE(cb_struct), TARGET :: crt_cb_struct, cls_cb_struct
+
+ CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1"
+ TYPE(C_FUNPTR) :: f1, f3, f5
+ TYPE(C_PTR) :: f2, f4, f6
+
+ CHARACTER(LEN=10) :: PROP1_NAME = "Property 1"
+ INTEGER(SIZE_T) :: PROP1_SIZE = 10
+ CHARACTER(LEN=10) :: PROP2_NAME = "Property 2"
+ INTEGER(SIZE_T) :: PROP2_SIZE = 10
+ CHARACTER(LEN=10) :: PROP3_NAME = "Property 3"
+ INTEGER(SIZE_T) :: PROP3_SIZE = 10
+ CHARACTER(LEN=10) :: PROP4_NAME = "Property 4"
+ INTEGER(SIZE_T) :: PROP4_SIZE = 10
+ INTEGER :: PROP1_DEF_VALUE = 10
+ INTEGER :: PROP2_DEF_VALUE = 10
+ INTEGER :: PROP3_DEF_VALUE = 10
+ INTEGER :: PROP4_DEF_VALUE = 10
+
+ INTEGER :: error ! /* Generic RETURN value */
+
+ f1 = C_FUNLOC(test_genprop_cls_cb1_f)
+ f5 = C_FUNLOC(test_genprop_cls_cb1_f)
+
+ f2 = C_LOC(crt_cb_struct)
+ f6 = C_LOC(cls_cb_struct)
+
+ !/* Create a new generic class, derived from the root of the class hierarchy */
+ CALL H5Pcreate_class_f(H5P_ROOT_F,CLASS1_NAME, cid1, error, f1, f2, c_null_funptr, c_null_ptr, f5, f6)
+ CALL check("H5Pcreate_class_f", error, total_error)
+
+ !/* Insert first property into class (with no callbacks) */
+ CALL H5Pregister_f(cid1, PROP1_NAME, PROP1_SIZE, PROP1_DEF_VALUE, error)
+ CALL check("H5Pregister_f", error, total_error)
+ !/* Insert second property into class (with no callbacks) */
+ CALL H5Pregister_f(cid1, PROP2_NAME, PROP2_SIZE, PROP2_DEF_VALUE, error)
+ CALL check("H5Pregister_f", error, total_error)
+ !/* Insert third property into class (with no callbacks) */
+ CALL H5Pregister_f(cid1, PROP3_NAME, PROP3_SIZE, PROP3_DEF_VALUE, error)
+ CALL check("H5Pregister_f", error, total_error)
+
+ !/* Insert fourth property into class (with no callbacks) */
+ CALL H5Pregister_f(cid1, PROP4_NAME, PROP4_SIZE, PROP4_DEF_VALUE, error)
+ CALL check("H5Pregister_f", error, total_error)
+
+ ! /* Check the number of properties in class */
+ CALL H5Pget_nprops_f(cid1, nprops, error)
+ CALL check("H5Pget_nprops_f", error, total_error)
+ CALL VERIFY("H5Pget_nprops_f", INT(nprops), 4, total_error)
+
+ ! /* Initialize class callback structs */
+
+ crt_cb_struct%count = 0
+ crt_cb_struct%id = -1
+ cls_cb_struct%count = 0
+ cls_cb_struct%id = -1
+
+ !/* Create a property list from the class */
+ CALL H5Pcreate_f(cid1, lid1, error)
+ CALL check("H5Pcreate", error, total_error)
+
+ !/* Verify that the creation callback occurred */
+ CALL VERIFY("H5Pcreate", INT(crt_cb_struct%count), 1, total_error)
+ CALL VERIFY("H5Pcreate", INT(crt_cb_struct%id), INT(lid1), total_error)
+
+ ! /* Check the number of properties in list */
+ CALL H5Pget_nprops_f(lid1,nprops, error)
+ CALL check("H5Pget_nprops_f", error, total_error)
+ CALL VERIFY("H5Pget_nprops_f", INT(nprops), 4, total_error)
+
+ ! /* Create another property list from the class */
+ CALL H5Pcreate_f(cid1, lid2, error)
+ CALL check("H5Pcreate", error, total_error)
+
+ ! /* Verify that the creation callback occurred */
+ CALL VERIFY("H5Pcreate", INT(crt_cb_struct%count), 2, total_error)
+ CALL VERIFY("H5Pcreate", INT(crt_cb_struct%id), INT(lid2), total_error)
+
+ ! /* Check the number of properties in list */
+ CALL H5Pget_nprops_f(lid2,nprops, error)
+ CALL check("H5Pget_nprops_f", error, total_error)
+ CALL VERIFY("H5Pget_nprops_f", INT(nprops), 4, total_error)
+
+ ! /* Close first list */
+ CALL H5Pclose_f(lid1, error);
+ CALL check("h5pclose", error, total_error)
+
+ !/* Verify that the close callback occurred */
+ CALL VERIFY("H5Pcreate", INT(cls_cb_struct%count), 1, total_error)
+ CALL VERIFY("H5Pcreate", INT(cls_cb_struct%id), INT(lid1), total_error)
+
+ !/* Close second list */
+ CALL H5Pclose_f(lid2, error);
+ CALL check("h5pclose", error, total_error)
+
+ !/* Verify that the close callback occurred */
+ CALL VERIFY("H5Pcreate", INT(cls_cb_struct%count), 2, total_error)
+ CALL VERIFY("H5Pcreate", INT(cls_cb_struct%id), INT(lid2), total_error)
+
+ !/* Close class */
+ CALL H5Pclose_class_f(cid1, error)
+ CALL check("H5Pclose_class_f", error, total_error)
+
+END SUBROUTINE test_genprop_class_callback
diff --git a/fortran/test/tH5R.f90 b/fortran/test/tH5R.f90
index 0289465..ac105fc 100644
--- a/fortran/test/tH5R.f90
+++ b/fortran/test/tH5R.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5R.f90
+!
+! NAME
+! tH5R.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5R, Reference Interface, APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,12 +22,14 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! NOTES
+! Tests h5rcreate_f, h5rdereference_f, h5rget_name_f
+! and H5Rget_object_type functions
!
+! CONTAINS SUBROUTINES
+! refobjtest, refregtest
!
-! Testing Reference Interface functionality.
-!
-! 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
@@ -230,6 +241,8 @@ END SUBROUTINE refobjtest
!
SUBROUTINE refregtest(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
+! use iso_c_binding ! NOTE: if this is uncommented, then need to move subroutine into another file.
+
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(OUT) :: total_error
@@ -249,23 +262,30 @@ SUBROUTINE refregtest(cleanup, total_error)
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
+! TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2), TARGET :: ref
+ TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref
+ TYPE(hdset_reg_ref_t_f) , DIMENSION(1:2) :: ref_out
+ INTEGER(HSIZE_T), DIMENSION(2) :: ref_dim = (/0,0/)
+ INTEGER(HSIZE_T), DIMENSION(2) :: data_dims ! = (/0,0/)
+ INTEGER(HSIZE_T), DIMENSION(2) :: dims = (/2,9/) ! Datasets dimensions
+ INTEGER(HSIZE_T), DIMENSION(1) :: dimsr = (/2/) !
+ INTEGER(HSIZE_T), DIMENSION(2) :: start ! = (/0,0/)
+ INTEGER(HSIZE_T), DIMENSION(2) :: count ! = (/0,0/)
+
INTEGER :: rankr = 1
INTEGER :: rank = 2
- INTEGER , DIMENSION(2,9) :: DATA
+! INTEGER , DIMENSION(2,9), TARGET :: DATA
+ INTEGER , DIMENSION(2,9) :: DATA
INTEGER , DIMENSION(2,9) :: data_out = 0
INTEGER(HSIZE_T) , DIMENSION(2,3) :: coord
INTEGER(SIZE_T) ::num_points = 3 ! Number of selected points
+! type(c_ptr) :: f_ptr
coord = RESHAPE((/1,1,2,7,1,9/), (/2,3/)) ! Coordinates of selected points
DATA = RESHAPE ((/1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6/), (/2,9/))
+ ref_out(1)%ref = 0
+ ref_out(2)%ref = 0
+
!
! Initialize FORTRAN predefined datatypes.
!
@@ -305,11 +325,16 @@ SUBROUTINE refregtest(cleanup, total_error)
CALL check("h5dcreate_f", error, total_error)
data_dims(1) = 2
data_dims(2) = 9
+
+! f_ptr = c_loc(data)
+! CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, f_ptr, error)
+
CALL h5dwrite_f(dsetv_id, H5T_NATIVE_INTEGER, DATA, data_dims, error)
CALL check("h5dwrite_f", error, total_error)
CALL h5dclose_f(dsetv_id, error)
CALL check("h5dclose_f", error, total_error)
+
!
! Dataset with references
!
@@ -326,8 +351,12 @@ SUBROUTINE refregtest(cleanup, total_error)
CALL h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, &
start, count, error)
CALL check("h5sselect_hyperslab_f", error, total_error)
+ ref(1)%ref(:) = 0
+! f_ptr = C_LOC(ref(1))
+! CALL h5rcreate_f(file_id, dsetnamev, 1, space_id, f_ptr, error)
CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(1), error)
CALL check("h5rcreate_f", error, total_error)
+
!
! Create a reference to elements selection.
!
@@ -336,6 +365,7 @@ SUBROUTINE refregtest(cleanup, total_error)
CALL h5sselect_elements_f(space_id, H5S_SELECT_SET_F, rank, num_points,&
coord, error)
CALL check("h5sselect_elements_f", error, total_error)
+ ref(2)%ref(:) = 0
CALL h5rcreate_f(file_id, dsetnamev, space_id, ref(2), error)
CALL check("h5rcreate_f", error, total_error)
!
@@ -355,6 +385,7 @@ SUBROUTINE refregtest(cleanup, total_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.
!
@@ -369,7 +400,6 @@ SUBROUTINE refregtest(cleanup, total_error)
CALL h5dread_f(dsetr_id, H5T_STD_REF_DSETREG, ref_out, ref_dim, error)
CALL check("h5dread_f", error, total_error)
-
! Get name of the dataset the first region reference points to using H5Rget_name_f
CALL H5Rget_name_f(dsetr_id, ref_out(1), buf, error, buf_size )
CALL check("H5Rget_name_f", error, total_error)
@@ -390,7 +420,6 @@ SUBROUTINE refregtest(cleanup, total_error)
CALL check("H5Rget_name_f", error, total_error)
CALL VERIFY("H5Rget_name_f", INT(buf_size),7,total_error)
CALL VerifyString("H5Rget_name_f", TRIM(buf_small), "/MAT", total_error)
-
!
! Dereference the first reference.
!
@@ -402,9 +431,7 @@ SUBROUTINE refregtest(cleanup, total_error)
! Get name of the dataset the second region reference points to using H5Rget_name_f
CALL H5Rget_name_f(dsetr_id, ref_out(2), buf, error) ! no optional size
CALL check("H5Rget_name_f", error, total_error)
- CALL VerifyString("H5Rget_name_f", buf, "/MATRIX", total_error)
-
-
+ CALL VerifyString("H5Rget_name_f", TRIM(buf), "/MATRIX", total_error)
!
! Read selected data from the dataset.
!
diff --git a/fortran/test/tH5S.f90 b/fortran/test/tH5S.f90
index b56d3a7..e3a44ad 100644
--- a/fortran/test/tH5S.f90
+++ b/fortran/test/tH5S.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5S.f90
+!
+! NAME
+! tH5S.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5S, Dataspace Interface, APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,17 +22,18 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
-!
-!
-! Testing Dataspace Interface functionality.
-!
-!
-! The following subroutine tests the following functionalities:
+! NOTES
+! Tests the following functionalities:
! h5screate_f, h5scopy_f, h5screate_simple_f, h5sis_simple_f,
! h5sget_simple_extent_dims_f,h5sget_simple_extent_ndims_f
! h5sget_simple_extent_npoints_f, h5sget_simple_extent_type_f,
! h5sextent_copy_f, h5sset_extent_simple_f, h5sset_extent_none_f
!
+! CONTAINS SUBROUTINES
+! dataspace_basic_test
+!
+!*****
+
SUBROUTINE dataspace_basic_test(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
@@ -162,7 +172,7 @@
CALL check("h5sget_simple_extent_type_f", error, total_error)
IF (classtype .NE. 1) write(*,*)"class type not H5S_SIMPLE_f"
- !
+ !
!set the copied space to none before extend the dimensions.
!
CALL h5sset_extent_none_f(space2_id, error)
diff --git a/fortran/test/tH5Sselect.f90 b/fortran/test/tH5Sselect.f90
index f7fd8af..1cbabe8 100644
--- a/fortran/test/tH5Sselect.f90
+++ b/fortran/test/tH5Sselect.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5Sselect.f90
+!
+! NAME
+! tH5Sselect.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5S, Selection-related Dataspace Interface, APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,18 +22,20 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
-!
-! Testing Selection-related Dataspace Interface functionality.
-!
-
-!
-! The following subroutines tests the following functionalities:
+! NOTES
+! Tests the following functionalities:
! h5sget_select_npoints_f, h5sselect_elements_f, h5sselect_all_f,
! h5sselect_none_f, h5sselect_valid_f, h5sselect_hyperslab_f,
! h5sget_select_bounds_f, h5sget_select_elem_pointlist_f,
! h5sget_select_elem_npoints_f, h5sget_select_hyper_blocklist_f,
-! h5sget_select_hyper_nblocks_f, h5sget_select_npoints_f
+! h5sget_select_hyper_nblocks_f, h5sget_select_npoints_f
+!
+! CONTAINS SUBROUTINES
+! test_select_hyperslab, test_select_element, test_basic_select,
+! test_select_point, test_select_combine, test_select_bounds
+!
!
+!*****
SUBROUTINE test_select_hyperslab(cleanup, total_error)
@@ -1021,13 +1032,13 @@
!****************************************************************/
SUBROUTINE test_select_point(cleanup, total_error)
- USE HDF5 ! This module contains all necessary modules
-
+ USE HDF5 ! This module contains all necessary modules
+
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(OUT) :: total_error
INTEGER(HID_T) :: xfer_plist
-
+
INTEGER, PARAMETER :: SPACE1_DIM1=3
INTEGER, PARAMETER :: SPACE1_DIM2=15
INTEGER, PARAMETER :: SPACE1_DIM3=13
@@ -1035,11 +1046,11 @@ SUBROUTINE test_select_point(cleanup, total_error)
INTEGER, PARAMETER :: SPACE2_DIM2=26
INTEGER, PARAMETER :: SPACE3_DIM1=15
INTEGER, PARAMETER :: SPACE3_DIM2=26
-
+
INTEGER, PARAMETER :: SPACE1_RANK=3
INTEGER, PARAMETER :: SPACE2_RANK=2
INTEGER, PARAMETER :: SPACE3_RANK=2
-
+
! /* Element selection information */
INTEGER, PARAMETER :: POINT1_NPOINTS=10
INTEGER(hid_t) ::fid1 ! /* HDF5 File IDs */
@@ -1048,7 +1059,7 @@ SUBROUTINE test_select_point(cleanup, total_error)
INTEGER(hsize_t), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/)
INTEGER(hsize_t), DIMENSION(1:2) :: dims2 = (/SPACE2_DIM1, SPACE2_DIM2/)
INTEGER(hsize_t), DIMENSION(1:2) :: dims3 = (/SPACE3_DIM1, SPACE3_DIM2/)
-
+
INTEGER(hsize_t), DIMENSION(1:SPACE1_RANK,1:POINT1_NPOINTS) :: coord1 !/* Coordinates for point selection */
INTEGER(hsize_t), DIMENSION(1:SPACE1_RANK,1:POINT1_NPOINTS) :: temp_coord1 !/* Coordinates for point selection */
INTEGER(hsize_t), DIMENSION(1:SPACE2_RANK,1:POINT1_NPOINTS) :: coord2 !/* Coordinates for point selection */
@@ -1064,7 +1075,7 @@ SUBROUTINE test_select_point(cleanup, total_error)
! struct pnt_iter pi; /* Custom Pointer iterator struct */
INTEGER :: error !/* Generic return value */
CHARACTER(LEN=9) :: filename = 'h5s_hyper'
- CHARACTER(LEN=80) :: fix_filename
+ CHARACTER(LEN=80) :: fix_filename
CHARACTER(LEN=1), DIMENSION(1:SPACE2_DIM1,1:SPACE2_DIM2) :: wbuf, rbuf
CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error)
@@ -1090,11 +1101,11 @@ SUBROUTINE test_select_point(cleanup, total_error)
!!$ for(i=0, tbuf=wbuf; i<SPACE2_DIM1; i++)
!!$ for(j=0; j<SPACE2_DIM2; j++)
!!$ *tbuf++=(uint8_t)((i*SPACE2_DIM2)+j);
-
+
!/* Create file */
CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, fid1, error)
CALL check("h5fcreate_f", error, total_error)
-
+
!/* Create dataspace for dataset */
CALL h5screate_simple_f(SPACE1_RANK, dims1, sid1, error)
CALL check("h5screate_simple_f", error, total_error)
@@ -1115,7 +1126,6 @@ SUBROUTINE test_select_point(cleanup, total_error)
coord1(1,9)=3; coord1(2,9)= 2; coord1(3,9)= 7;
coord1(1,10)=1; coord1(2,10)= 4; coord1(3,10)= 9
-
CALL h5sselect_elements_f(sid1, H5S_SELECT_SET_F, SPACE1_RANK, INT(POINT1_NPOINTS,size_t), coord1, error)
CALL check("h5sselect_elements_f", error, total_error)
@@ -1151,7 +1161,7 @@ SUBROUTINE test_select_point(cleanup, total_error)
CALL h5sselect_elements_f(sid1, H5S_SELECT_APPEND_F, SPACE1_RANK, INT(POINT1_NPOINTS,size_t), coord1, error)
CALL check("h5sselect_elements_f", error, total_error)
! /* Verify correct elements selected */
-
+
CALL h5sget_select_elem_pointlist_f(sid1, INT(POINT1_NPOINTS,hsize_t), INT(POINT1_NPOINTS,hsize_t),temp_coord1,error)
CALL check("h5sget_select_elem_pointlist_f", error, total_error)
@@ -1182,7 +1192,7 @@ SUBROUTINE test_select_point(cleanup, total_error)
!/* Verify correct elements selected */
-
+
CALL h5sget_select_elem_pointlist_f(sid2, INT(0,hsize_t), INT(POINT1_NPOINTS,hsize_t),temp_coord2,error)
CALL check("h5sget_select_elem_pointlist_f", error, total_error)
@@ -1333,7 +1343,6 @@ SUBROUTINE test_select_point(cleanup, total_error)
CALL h5fclose_f(fid1, 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)
@@ -1349,8 +1358,8 @@ END SUBROUTINE test_select_point
!****************************************************************/
SUBROUTINE test_select_combine(cleanup, total_error)
- USE HDF5 ! This module contains all necessary modules
-
+ USE HDF5 ! This module contains all necessary modules
+
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(OUT) :: total_error
@@ -1358,7 +1367,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
INTEGER, PARAMETER :: SPACE7_RANK = 2
INTEGER, PARAMETER :: SPACE7_DIM1 = 10
INTEGER, PARAMETER :: SPACE7_DIM2 = 10
-
+
INTEGER(hid_t) :: base_id ! /* Base dataspace for test */
INTEGER(hid_t) :: all_id ! /* Dataspace for "all" selection */
INTEGER(hid_t) :: none_id ! /* Dataspace for "none" selection */
@@ -1378,7 +1387,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5screate_simple_f", error, total_error)
! /* Copy base dataspace and set selection to "all" */
- CALL h5scopy_f(base_id, all_id, error)
+ CALL h5scopy_f(base_id, all_id, error)
CALL check("h5scopy_f", error, total_error)
CALL H5Sselect_all_f(all_id, error)
@@ -1389,7 +1398,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL VERIFY("H5Sget_select_type_f", INT(sel_type), INT(H5S_SEL_ALL_F), total_error)
!/* Copy base dataspace and set selection to "none" */
- CALL h5scopy_f(base_id, none_id, error)
+ CALL h5scopy_f(base_id, none_id, error)
CALL check("h5scopy_f", error, total_error)
CALL H5Sselect_none_f(none_id, error)
@@ -1398,9 +1407,9 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL H5Sget_select_type_f(none_id, sel_type, error)
CALL check("H5Sget_select_type_f", error, total_error)
CALL VERIFY("H5Sget_select_type_f", INT(sel_type), INT(H5S_SEL_NONE_F), total_error)
-
+
!/* Copy "all" selection & space */
- CALL H5Scopy_f(all_id, space1, error)
+ CALL H5Scopy_f(all_id, space1, error)
CALL check("h5scopy_f", error, total_error)
!/* 'OR' "all" selection with another hyperslab */
@@ -1409,7 +1418,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
icount(1:2) = 1
iblock(1:2) = (/5,4/)
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_OR_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
!/* Verify that it's still "all" selection */
@@ -1422,7 +1431,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
!/* Copy "all" selection & space */
- CALL H5Scopy_f(all_id, space1, error)
+ CALL H5Scopy_f(all_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'AND' "all" selection with another hyperslab */
@@ -1431,7 +1440,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
icount(1:2) = 1
iblock(1:2) = (/5,4/)
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_AND_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
!/* Verify that the new selection is the same at the original block */
@@ -1443,7 +1452,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL h5sget_select_hyper_nblocks_f(space1, nblocks, error)
CALL check("h5sget_select_hyper_nblocks_f", error, total_error)
CALL VERIFY("h5sget_select_hyper_nblocks_f", INT(nblocks), 1, total_error)
-
+
!/* Retrieve the block defined */
CALL h5sget_select_hyper_blocklist_f(space1, INT(0, hsize_t), INT(nblocks,hsize_t), blocks, error)
CALL check("h5sget_select_hyper_blocklist_f", error, total_error)
@@ -1460,7 +1469,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
!/* Copy "all" selection & space */
- CALL H5Scopy_f(all_id, space1, error)
+ CALL H5Scopy_f(all_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'XOR' "all" selection with another hyperslab */
@@ -1470,7 +1479,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/)
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_XOR_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is an inversion of the original block */
@@ -1491,7 +1500,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
! /* Verify that the correct block is defined */
- ! No guarantee is implied as the order in which blocks are listed.
+ ! No guarantee is implied as the order in which blocks are listed.
! So this will ONLY work for square domains iblock(1:2) = (/5,5/)
!!$ CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(1,1,1)), 1, total_error)
!!$ CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(2,1,1)), 5, total_error)
@@ -1512,7 +1521,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "all" selection & space */
- CALL H5Scopy_f(all_id, space1, error)
+ CALL H5Scopy_f(all_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'NOTB' "all" selection with another hyperslab */
@@ -1522,7 +1531,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_NOTB_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is an inversion of the original block */
@@ -1540,9 +1549,9 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL h5sget_select_hyper_blocklist_f(space1, INT(0, hsize_t), INT(nblocks,hsize_t), blocks, error)
CALL check("h5sget_select_hyper_blocklist_f", error, total_error)
- ! /* Verify that the correct block is defined */
+ ! /* Verify that the correct block is defined */
- ! No guarantee is implied as the order in which blocks are listed.
+ ! No guarantee is implied as the order in which blocks are listed.
! So this will ONLY work for square domains iblock(1:2) = (/5,5/)
!!$ CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(1,1,1)), 1, total_error)
@@ -1564,7 +1573,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL h5sclose_f(space1, error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "all" selection & space */
- CALL H5Scopy_f(all_id, space1, error)
+ CALL H5Scopy_f(all_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'NOTA' "all" selection with another hyperslab */
@@ -1574,7 +1583,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_NOTA_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
!/* Verify that the new selection is the "none" selection */
@@ -1587,7 +1596,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "none" selection & space */
- CALL H5Scopy_f(none_id, space1, error)
+ CALL H5Scopy_f(none_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'OR' "none" selection with another hyperslab */
@@ -1597,14 +1606,14 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_OR_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is the same as the original hyperslab */
CALL H5Sget_select_type_f(space1, sel_type, error)
CALL check("H5Sget_select_type_f", error, total_error)
CALL VERIFY("H5Sget_select_type_f", INT(sel_type), INT( H5S_SEL_HYPERSLABS_F), total_error)
-
+
! /* Verify that there is only one block */
CALL h5sget_select_hyper_nblocks_f(space1, nblocks, error)
@@ -1627,7 +1636,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "none" selection & space */
- CALL H5Scopy_f(none_id, space1, error)
+ CALL H5Scopy_f(none_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'AND' "none" selection with another hyperslab */
@@ -1637,7 +1646,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_AND_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is the "none" selection */
@@ -1650,7 +1659,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "none" selection & space */
- CALL H5Scopy_f(none_id, space1, error)
+ CALL H5Scopy_f(none_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'XOR' "none" selection with another hyperslab */
@@ -1660,14 +1669,14 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_XOR_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is the same as the original hyperslab */
CALL H5Sget_select_type_f(space1, sel_type, error)
CALL check("H5Sget_select_type_f", error, total_error)
CALL VERIFY("H5Sget_select_type_f", INT(sel_type), INT( H5S_SEL_HYPERSLABS_F), total_error)
-
+
! /* Verify that there is only one block */
CALL h5sget_select_hyper_nblocks_f(space1, nblocks, error)
@@ -1683,13 +1692,13 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(2,1,1)), 1, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(3,1,1)), 5, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(4,1,1)), 4, total_error)
-
+
! /* Close temporary dataspace */
CALL h5sclose_f(space1, error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "none" selection & space */
- CALL H5Scopy_f(none_id, space1, error)
+ CALL H5Scopy_f(none_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'NOTB' "none" selection with another hyperslab */
@@ -1699,7 +1708,7 @@ SUBROUTINE test_select_combine(cleanup, total_error)
iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_NOTB_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is the "none" selection */
@@ -1712,23 +1721,23 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL check("h5sclose_f", error, total_error)
! /* Copy "none" selection & space */
- CALL H5Scopy_f(none_id, space1, error)
+ CALL H5Scopy_f(none_id, space1, error)
CALL check("h5scopy_f", error, total_error)
! /* 'NOTA' "none" selection with another hyperslab */
start(1:2) = 0
stride(1:2) = 1
icount(1:2) = 1
- iblock(1:2) = (/5,4/) !5
+ iblock(1:2) = (/5,4/) !5
CALL h5sselect_hyperslab_f(space1, H5S_SELECT_NOTA_F, start, &
- icount, error, stride, iblock)
+ icount, error, stride, iblock)
CALL check("h5sselect_hyperslab_f", error, total_error)
! /* Verify that the new selection is the same as the original hyperslab */
CALL H5Sget_select_type_f(space1, sel_type, error)
CALL check("H5Sget_select_type_f", error, total_error)
CALL VERIFY("H5Sget_select_type_f", INT(sel_type), INT( H5S_SEL_HYPERSLABS_F), total_error)
-
+
! /* Verify that there is ONLY one BLOCK */
CALL h5sget_select_hyper_nblocks_f(space1, nblocks, error)
CALL check("h5sget_select_hyper_nblocks_f", error, total_error)
@@ -1747,13 +1756,13 @@ SUBROUTINE test_select_combine(cleanup, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(2,1,1)), 1, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(3,1,1)), 5, total_error)
CALL VERIFY("h5sget_select_hyper_blocklist_f", INT(blocks(4,1,1)), 4, total_error)
-
+
! /* Close temporary dataspace */
CALL h5sclose_f(space1, error)
CALL check("h5sclose_f", error, total_error)
! /* Close dataspaces */
-
+
CALL h5sclose_f(base_id, error)
CALL check("h5sclose_f", error, total_error)
CALL h5sclose_f(all_id, error)
@@ -1771,8 +1780,8 @@ END SUBROUTINE test_select_combine
!****************************************************************/
SUBROUTINE test_select_bounds(cleanup, total_error)
- USE HDF5 ! This module contains all necessary modules
-
+ USE HDF5 ! This module contains all necessary modules
+
IMPLICIT NONE
LOGICAL, INTENT(IN) :: cleanup
INTEGER, INTENT(OUT) :: total_error
@@ -1781,7 +1790,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
INTEGER, PARAMETER :: SPACE11_DIM1=100
INTEGER, PARAMETER :: SPACE11_DIM2=50
INTEGER, PARAMETER :: SPACE11_NPOINTS=4
-
+
INTEGER(hid_t) :: sid ! /* Dataspace ID */
INTEGER(hsize_t), DIMENSION(1:SPACE11_RANK) :: dims = (/SPACE11_DIM1, SPACE11_DIM2/) !Dataspace dimensions
INTEGER(hsize_t), DIMENSION(SPACE11_RANK, SPACE11_NPOINTS) :: coord !/* Coordinates for point selection
@@ -1792,7 +1801,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
INTEGER(hssize_t), DIMENSION(SPACE11_RANK) :: offset !/* Offset amount for selection */
INTEGER(hsize_t), DIMENSION(SPACE11_RANK) :: low_bounds !/* The low bounds for the selection */
INTEGER(hsize_t), DIMENSION(SPACE11_RANK) :: high_bounds !/* The high bounds for the selection */
-
+
INTEGER :: error
!/* Create dataspace */
@@ -1836,7 +1845,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
CALL VERIFY("h5sget_select_bounds_f", error, -1, total_error)
!/* Set point selection */
-
+
coord(1,1)= 3; coord(2,1)= 3;
coord(1,2)= 3; coord(2,2)= 46;
coord(1,3)= 96; coord(2,3)= 3;
@@ -1863,7 +1872,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
! /* Get bounds for hyperslab selection with negative offset */
CALL h5sget_select_bounds_f(sid, low_bounds, high_bounds, error)
CALL VERIFY("h5sget_select_bounds_f", error, -1, total_error)
-
+
! /* Set valid offset for selection */
offset(1:2) = (/2,-2/)
CALL H5Soffset_simple_f(sid, offset, error)
@@ -1888,9 +1897,9 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
stride(1:2) = 10
count(1:2) = 4
block(1:2) = 5
-
+
CALL h5sselect_hyperslab_f(sid, H5S_SELECT_SET_F, start, &
- count, error, stride, block)
+ count, error, stride, block)
CALL check("h5sselect_hyperslab_f", error, total_error)
!/* Get bounds for hyperslab selection */
@@ -1929,7 +1938,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
offset(1:2) = 0
CALL H5Soffset_simple_f(sid, offset, error)
CALL check("H5Soffset_simple_f", error, total_error)
-
+
! /* Make "irregular" hyperslab selection */
start(1:2) = 20
stride(1:2) = 20
@@ -1937,7 +1946,7 @@ SUBROUTINE test_select_bounds(cleanup, total_error)
block(1:2) = 10
CALL h5sselect_hyperslab_f(sid, H5S_SELECT_OR_F, start, &
- count, error, stride, block)
+ count, error, stride, block)
CALL check("h5sselect_hyperslab_f", error, total_error)
!/* Get bounds for hyperslab selection */
diff --git a/fortran/test/tH5T.f90 b/fortran/test/tH5T.f90
index d298694..6af1ba6 100644
--- a/fortran/test/tH5T.f90
+++ b/fortran/test/tH5T.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5T.f90
+!
+! NAME
+! tH5T.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5T APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! compoundtest, basic_data_type_test, enumtest, test_derived_flt
+!
+!*****
+
SUBROUTINE compoundtest(cleanup, total_error)
!
! This program creates a dataset that is one dimensional array of
@@ -822,7 +836,7 @@
INTEGER, DIMENSION(2) :: data
INTEGER(HSIZE_T), DIMENSION(7) :: dims
INTEGER :: order1, order2
- INTEGER(SIZE_T) :: type_size1, type_size2
+! INTEGER(SIZE_T) :: type_size1, type_size2
INTEGER :: class
dims(1) = 2
@@ -946,7 +960,7 @@ SUBROUTINE test_derived_flt(cleanup, total_error)
INTEGER, INTENT(OUT) :: total_error
INTEGER(hid_t) :: file=-1, tid1=-1, tid2=-1
INTEGER(hid_t) :: dxpl_id=-1
- INTEGER(size_t) :: spos, epos, esize, mpos, msize, size
+ INTEGER(size_t) :: spos, epos, esize, mpos, msize
CHARACTER(LEN=15), PARAMETER :: filename="h5t_derived_flt"
CHARACTER(LEN=80) :: fix_filename
diff --git a/fortran/test/tH5T_F03.f90 b/fortran/test/tH5T_F03.f90
new file mode 100644
index 0000000..57e833c
--- /dev/null
+++ b/fortran/test/tH5T_F03.f90
@@ -0,0 +1,2549 @@
+!****h* root/fortran/test/tH5T_F03.f90
+!
+! NAME
+! tH5T_F03.f90
+!
+! FUNCTION
+! Test FORTRAN HDF5 H5T APIs which are dependent on FORTRAN 2003
+! features.
+!
+! COPYRIGHT
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+! Copyright by The HDF Group. *
+! Copyright by the Board of Trustees of the University of Illinois. *
+! All rights reserved. *
+! *
+! This file is part of HDF5. The full HDF5 copyright notice, including *
+! terms governing use, modification, and redistribution, is contained in *
+! the files COPYING and Copyright.html. COPYING can be found at the root *
+! of the source code distribution tree; Copyright.html can be found at the *
+! root level of an installed copy of the electronic HDF5 document set and *
+! is linked from the top-level documents page. It can also be found at *
+! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
+! access to either file, you may request a copy from help@hdfgroup.org. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+!
+! CONTAINS SUBROUTINES
+! test_array_compound_atomic, test_array_compound_array,
+! test_array_bkg, test_h5kind_to_type
+!
+!*****
+
+! *****************************************
+! *** H 5 T T E S T S
+! *****************************************
+
+!/****************************************************************
+!**
+!** test_array_compound_atomic(): Test basic array datatype code.
+!** Tests 1-D array of compound datatypes (with no array fields)
+!**
+!****************************************************************/
+!
+SUBROUTINE test_array_compound_atomic(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ ! 1-D dataset WITH fixed dimensions
+ CHARACTER(LEN=6), PARAMETER :: SPACE1_NAME = "Space1"
+ INTEGER, PARAMETER :: SPACE1_RANK = 1
+ INTEGER, PARAMETER :: SPACE1_DIM1 = 4
+ ! 1-D array datatype
+ INTEGER, PARAMETER :: ARRAY1_RANK= 1
+ INTEGER, PARAMETER :: ARRAY1_DIM1= 4
+ CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray1.h5"
+
+ TYPE s1_t
+ INTEGER :: i
+ REAL :: f
+ END TYPE s1_t
+ TYPE(s1_t), DIMENSION(:,:), ALLOCATABLE, TARGET :: wdata ! Information to write
+ TYPE(s1_t), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Information read in
+ INTEGER(hid_t) :: fid1 ! HDF5 File IDs
+ INTEGER(hid_t) :: dataset ! Dataset ID
+ INTEGER(hid_t) :: sid1 ! Dataspace ID
+ INTEGER(hid_t) :: tid1 ! Array Datatype ID
+ INTEGER(hid_t) :: tid2 ! Compound Datatype ID
+
+ INTEGER(HSIZE_T), DIMENSION(1) :: sdims1 = (/SPACE1_DIM1/)
+ INTEGER(HSIZE_T), DIMENSION(1) :: tdims1=(/ARRAY1_DIM1/)
+ INTEGER :: ndims ! Array rank for reading
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims ! Array dimensions for reading
+ INTEGER :: nmemb ! Number of compound members
+ CHARACTER(LEN=20) :: mname ! Name of compound field
+ INTEGER(size_t) :: off ! Offset of compound field
+ INTEGER(hid_t) :: mtid ! Datatype ID for field
+ INTEGER :: i,j ! counting variables
+ INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
+ INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
+
+ INTEGER(SIZE_T) :: sizeof_compound ! total size of compound
+ INTEGER :: error ! Generic RETURN value
+ INTEGER(SIZE_T) :: offset ! Member's offset
+ INTEGER :: namelen
+ LOGICAL :: flag
+
+ TYPE(C_PTR) :: f_ptr ! Needed to pass the pointer, for g95 compiler to work
+
+ ALLOCATE( wdata(1:SPACE1_DIM1,1:ARRAY1_DIM1) )
+ ALLOCATE( rdata(1:SPACE1_DIM1,1:ARRAY1_DIM1) )
+
+ ! Initialize array data to write
+ DO i = 1, SPACE1_DIM1
+ DO j = 1, ARRAY1_DIM1
+ wdata(i,j)%i = i * 10 + j
+ wdata(i,j)%f = i * 2.5 + j
+ ENDDO
+ ENDDO
+
+ ! Create file
+ CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid1,error)
+ CALL check("h5fcreate_f", error, total_error)
+
+ ! Create dataspace for datasets
+ CALL h5screate_simple_f(SPACE1_RANK, sdims1, sid1, error)
+ CALL check("h5screate_simple_f", error, total_error)
+
+ CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(wdata(1,1)), C_LOC(wdata(2,1))), tid2, error)
+ CALL check("h5tcreate_f", error, total_error)
+
+ ! Insert integer field
+ CALL h5tinsert_f(tid2, "i", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%i)), H5T_NATIVE_INTEGER, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ ! Insert float field
+
+ CALL h5tinsert_f(tid2, "f", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), H5T_NATIVE_REAL, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ ! Create an array datatype to refer to
+ CALL h5tarray_create_f(tid2, ARRAY1_RANK, tdims1, tid1, error)
+ CALL check("h5tarray_create_f", error, total_error)
+
+ ! Close compound datatype
+ CALL h5tclose_f(tid2,error)
+ CALL check("h5tclose_f", error, total_error)
+
+
+ ! Create a dataset
+ CALL h5dcreate_f(fid1,"Dataset1",tid1, sid1, dataset,error)
+ CALL check("h5dcreate_f", error, total_error)
+
+ ! Write dataset to disk
+
+ ALLOCATE(rdims(1:2)) ! dummy not needed
+
+ f_ptr = C_LOC(wdata(1,1))
+ CALL h5dwrite_f(dataset, tid1, f_ptr, error )
+ CALL check("h5dwrite_f", error, total_error)
+ ! Close Dataset
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ ! Close datatype
+ CALL h5tclose_f(tid1,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close disk dataspace
+ CALL h5sclose_f(sid1,error)
+ CALL check("h5sclose_f", error, total_error)
+
+ ! Close file
+ CALL h5fclose_f(fid1,error)
+ CALL check("h5fclose_f", error, total_error)
+
+ ! Re-open file
+ CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, fid1, error)
+ CALL check("h5fopen_f", error, total_error)
+
+ ! Open the dataset
+ CALL h5dopen_f(fid1, "Dataset1", dataset, error)
+ CALL check("h5dopen_f", error, total_error)
+
+ ! Get the datatype
+ CALL h5dget_type_f(dataset, tid1, error)
+ CALL check("h5dget_type_f", error, total_error)
+
+ ! Check the array rank
+ CALL h5tget_array_ndims_f(tid1, ndims, error)
+ CALL check("h5tget_array_ndims_f", error, total_error)
+ CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
+
+ ! Get the array dimensions
+ ALLOCATE(rdims1(1:ndims))
+ CALL h5tget_array_dims_f(tid1, rdims1, error)
+ CALL check("h5tget_array_dims_f", error, total_error)
+
+
+ ! Check the array dimensions
+ DO i = 1, ndims
+ CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims1(i)), total_error)
+ ENDDO
+
+ ! Get the compound datatype
+ CALL h5tget_super_f(tid1, tid2, error)
+ CALL check("h5tget_super_f", error, total_error)
+
+ ! Check the number of members
+ CALL h5tget_nmembers_f(tid2, nmemb, error)
+ CALL check("h5tget_nmembers_f", error, total_error)
+ CALL VERIFY("h5tget_nmembers_f", nmemb, 2, total_error)
+
+ ! Check the 1st field's name
+ CALL H5Tget_member_name_f(tid2, 0, mname, namelen,error)
+ CALL check("H5Tget_member_name_f", error, total_error)
+ CALL verifystring("H5Tget_member_name_f",mname(1:namelen),"i", total_error)
+
+ ! Check the 1st field's offset
+ CALL H5Tget_member_offset_f(tid2, 0, off, error)
+ CALL check("H5Tget_member_offset_f", error, total_error)
+ CALL VERIFY("H5Tget_member_offset_f",INT(off),0, total_error)
+
+ ! Check the 1st field's datatype
+ CALL H5Tget_member_type_f(tid2, 0, mtid, error)
+ CALL check("H5Tget_member_type_f", error, total_error)
+
+ CALL H5Tequal_f(mtid, H5T_NATIVE_INTEGER, flag, error)
+ CALL check("H5Tequal_f", error, total_error)
+ CALL VerifyLogical("H5Tequal_f", flag, .TRUE., total_error)
+
+ CALL h5tclose_f(mtid,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Check the 2nd field's name
+ CALL H5Tget_member_name_f(tid2, 1, mname, namelen,error)
+ CALL check("H5Tget_member_name_f", error, total_error)
+ CALL verifystring("H5Tget_member_name_f",mname(1:namelen),"f", total_error)
+
+ ! Check the 2nd field's offset
+ CALL H5Tget_member_offset_f(tid2, 1, off, error)
+ CALL check("H5Tget_member_offset_f", error, total_error)
+ CALL VERIFY("H5Tget_member_offset_f",INT(off),H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), total_error)
+
+ ! Check the 2nd field's datatype
+ CALL H5Tget_member_type_f(tid2, 1, mtid, error)
+ CALL check("H5Tget_member_type_f", error, total_error)
+
+ CALL H5Tequal_f(mtid, H5T_NATIVE_REAL, flag, error)
+ CALL check("H5Tequal_f", error, total_error)
+ CALL VerifyLogical("H5Tequal_f", flag, .TRUE., total_error)
+
+ CALL h5tclose_f(mtid,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close Compound Datatype
+ CALL h5tclose_f(tid2, error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Read dataset from disk
+
+ f_ptr = C_LOC(rdata(1,1))
+ CALL H5Dread_f(dataset, tid1, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+ ! Compare data read in
+ DO i = 1, SPACE1_DIM1
+ DO j = 1, ARRAY1_DIM1
+ IF(wdata(i,j)%i.NE.rdata(i,j)%i)THEN
+ PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF(wdata(i,j)%f.NE.rdata(i,j)%f)THEN
+ PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ! Close Datatype
+ CALL h5tclose_f(tid1,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close Dataset
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ ! Close file
+ CALL h5fclose_f(fid1,error)
+ CALL check("h5fclose_f", error, total_error)
+
+END SUBROUTINE test_array_compound_atomic
+!!$
+!!$!***************************************************************
+!!$!**
+!!$!** test_array_compound_array(): Test basic array datatype code.
+!!$!** Tests 1-D array of compound datatypes (with array fields)
+!!$!**
+!!$!***************************************************************
+!!$
+ SUBROUTINE test_array_compound_array(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ ! 1-D array datatype
+ INTEGER, PARAMETER :: ARRAY1_RANK= 1
+ INTEGER, PARAMETER :: ARRAY1_DIM1= 3
+ INTEGER, PARAMETER :: ARRAY2_DIM1= 5
+
+ INTEGER, PARAMETER :: SPACE1_RANK = 1
+ INTEGER, PARAMETER :: SPACE1_DIM1 = 4
+ CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray2.h5"
+
+ TYPE st_t_struct ! Typedef for compound datatype
+ INTEGER :: i
+ REAL, DIMENSION(1:ARRAY2_DIM1) :: f
+ CHARACTER(LEN=2), DIMENSION(1:ARRAY2_DIM1) :: c
+ END TYPE st_t_struct
+ ! Information to write
+ TYPE(st_t_struct), DIMENSION(1:SPACE1_DIM1,1:ARRAY1_DIM1), TARGET :: wdata
+ ! Information read in
+ TYPE(st_t_struct), DIMENSION(1:SPACE1_DIM1,1:ARRAY1_DIM1), TARGET :: rdata
+
+
+ INTEGER(hid_t) :: fid1 ! HDF5 File IDs
+ INTEGER(hid_t) :: dataset ! Dataset ID
+ integer(hid_t) :: sid1 ! Dataspace ID
+ integer(hid_t) :: tid1 ! Array Datatype ID
+ integer(hid_t) :: tid2 ! Compound Datatype ID
+ integer(hid_t) :: tid3 ! Nested Array Datatype ID
+ integer(hid_t) :: tid4 ! Nested Array Datatype ID
+ INTEGER(HID_T) :: dt5_id ! Memory datatype identifier
+
+ INTEGER(HSIZE_T), DIMENSION(1) :: sdims1 = (/SPACE1_DIM1/)
+ INTEGER(HSIZE_T), DIMENSION(1) :: tdims1=(/ARRAY1_DIM1/)
+ INTEGER(HSIZE_T), DIMENSION(1) :: tdims2=(/ARRAY2_DIM1/)
+
+ INTEGER ndims ! Array rank for reading
+
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims ! Array dimensions for reading
+
+ INTEGER :: nmemb ! Number of compound members
+ CHARACTER(LEN=20) :: mname ! Name of compound field
+ INTEGER(size_t) :: off ! Offset of compound field
+ INTEGER(size_t) :: offset ! Offset of compound field
+ INTEGER(hid_t) :: mtid ! Datatype ID for field
+ INTEGER(hid_t) :: mtid2 ! Datatype ID for field
+ INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
+ INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
+ INTEGER(SIZE_T) :: type_sizec ! Size of the character datatype
+ INTEGER(SIZE_T) :: sizeof_compound ! total size of compound
+
+ INTEGER :: mclass ! Datatype class for field
+ INTEGER :: i,j,k ! counting variables
+
+ INTEGER :: error
+ CHARACTER(LEN=2) :: ichr2
+ INTEGER(SIZE_T) :: sizechar
+ INTEGER :: namelen
+ LOGICAL :: flag
+ INTEGER(HID_T) :: atype_id !String Attribute Datatype identifier
+ INTEGER(SIZE_T) :: attrlen ! Length of the attribute string
+
+ TYPE(c_ptr) :: f_ptr
+
+ ! Initialize array data to write
+ DO i = 1, SPACE1_DIM1
+ DO j = 1, array1_DIM1
+ wdata(i,j)%i = i*10+j
+ DO k = 1, ARRAY2_DIM1
+ wdata(i,j)%f(k) = 10*i+j+.5
+ WRITE(ichr2,'(I2.2)') k
+ wdata(i,j)%c(k) = ichr2
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ! Create file
+ CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid1,error)
+ CALL check("h5fcreate_f", error, total_error)
+
+
+ ! Create dataspace for datasets
+ CALL h5screate_simple_f(SPACE1_RANK, sdims1, sid1, error)
+ CALL check("h5screate_simple_f", error, total_error)
+
+ ! Create a compound datatype to refer to
+ !
+ CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(wdata(1,1)), C_LOC(wdata(2,1))), tid2, error)
+ CALL check("h5tcreate_f", error, total_error)
+
+ ! Insert integer field
+ CALL h5tinsert_f(tid2, "i", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%i)), H5T_NATIVE_INTEGER, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ ! Create an array of floats datatype
+ CALL h5tarray_create_f(H5T_NATIVE_REAL, ARRAY1_RANK, tdims2, tid3, error)
+ CALL check("h5tarray_create_f", error, total_error)
+ ! Insert float array field
+
+ CALL h5tinsert_f(tid2, "f", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), tid3, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ !
+ ! Create datatype for the String attribute.
+ !
+ CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error)
+ CALL check("h5tcopy_f",error,total_error)
+
+ attrlen = LEN(wdata(1,1)%c(1))
+ CALL h5tset_size_f(atype_id, attrlen, error)
+ CALL check("h5tset_size_f",error,total_error)
+
+ ! Create an array of character datatype
+ CALL h5tarray_create_f(atype_id, ARRAY1_RANK, tdims2, tid4, error)
+ CALL check("h5tarray_create_f", error, total_error)
+
+ ! Insert character array field
+ CALL h5tinsert_f(tid2, "c", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%c(1))), tid4, error)
+ CALL check("h5tinsert2_f", error, total_error)
+
+ ! Close array of floats field datatype
+ CALL h5tclose_f(tid3,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ CALL h5tclose_f(tid4,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Create an array datatype to refer to
+ CALL h5tarray_create_f(tid2, ARRAY1_RANK, tdims1, tid1, error)
+ CALL check("h5tarray_create_f", error, total_error)
+
+ ! Close compound datatype
+ CALL h5tclose_f(tid2,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Create a dataset
+ CALL h5dcreate_f(fid1,"Dataset1",tid1, sid1, dataset,error)
+ CALL check("h5dcreate_f", error, total_error)
+
+
+ ! Write dataset to disk
+ f_ptr = C_LOC(wdata(1,1))
+ CALL h5dwrite_f(dataset, tid1, f_ptr, error )
+ CALL check("h5dwrite_f", error, total_error)
+
+ ! Close Dataset
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ ! Close datatype
+ CALL h5tclose_f(tid1,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close disk dataspace
+ CALL h5sclose_f(sid1,error)
+ CALL check("h5sclose_f", error, total_error)
+
+ ! Close file
+ CALL h5fclose_f(fid1,error)
+ CALL check("h5fclose_f", error, total_error)
+
+ ! Re-open file
+ CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, fid1, error)
+ CALL check("h5fopen_f", error, total_error)
+
+ ! Open the dataset
+
+ CALL h5dopen_f(fid1, "Dataset1", dataset, error)
+ CALL check("h5dopen_f", error, total_error)
+
+ ! Get the datatype
+ CALL h5dget_type_f(dataset, tid1, error)
+ CALL check("h5dget_type_f", error, total_error)
+
+ ! Check the array rank
+ CALL h5tget_array_ndims_f(tid1, ndims, error)
+ CALL check("h5tget_array_ndims_f", error, total_error)
+ CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
+
+
+ ! Get the array dimensions
+ ALLOCATE(rdims1(1:ndims))
+ CALL h5tget_array_dims_f(tid1, rdims1, error)
+ CALL check("h5tget_array_dims_f", error, total_error)
+
+ ! Check the array dimensions
+ DO i = 1, ndims
+ CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims1(i)), total_error)
+ ENDDO
+
+ ! Get the compound datatype
+ CALL h5tget_super_f(tid1, tid2, error)
+ CALL check("h5tget_super_f", error, total_error)
+
+ ! Check the number of members
+ CALL h5tget_nmembers_f(tid2, nmemb, error)
+ CALL check("h5tget_nmembers_f", error, total_error)
+ CALL VERIFY("h5tget_nmembers_f", nmemb, 3, total_error)
+
+ ! Check the 1st field's name
+ CALL H5Tget_member_name_f(tid2, 0, mname, namelen,error)
+ CALL check("H5Tget_member_name_f", error, total_error)
+ CALL verifystring("H5Tget_member_name_f",mname(1:namelen),"i", total_error)
+
+ ! Check the 1st field's offset
+
+ CALL H5Tget_member_offset_f(tid2, 0, off, error)
+ CALL check("H5Tget_member_offset_f", error, total_error)
+ CALL VERIFY("H5Tget_member_offset_f",INT(off),0, total_error)
+
+ ! Check the 1st field's datatype
+ CALL H5Tget_member_type_f(tid2, 0, mtid, error)
+ CALL check("H5Tget_member_type_f", error, total_error)
+
+ CALL H5Tequal_f(mtid, H5T_NATIVE_INTEGER, flag, error)
+ CALL check("H5Tequal_f", error, total_error)
+ CALL VerifyLogical("H5Tequal_f", flag, .TRUE., total_error)
+
+ CALL h5tclose_f(mtid,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Check the 2nd field's name
+ CALL H5Tget_member_name_f(tid2, 1, mname, namelen,error)
+ CALL check("H5Tget_member_name_f", error, total_error)
+ CALL verifystring("H5Tget_member_name_f",mname(1:namelen),"f", total_error)
+
+ ! Check the 2nd field's offset
+ CALL H5Tget_member_offset_f(tid2, 1, off, error)
+ CALL check("H5Tget_member_offset_f", error, total_error)
+ CALL VERIFY("H5Tget_member_offset_f",INT(off),H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), total_error)
+
+ ! Check the 2nd field's datatype
+ CALL H5Tget_member_type_f(tid2, 1, mtid, error)
+ CALL check("H5Tget_member_type_f", error, total_error)
+
+ ! Get the 2nd field's class
+ CALL H5Tget_class_f(mtid, mclass, error)
+ CALL check("H5Tget_class_f", error, total_error)
+ CALL VERIFY("H5Tget_class_f",mclass, H5T_ARRAY_F, total_error)
+
+ ! Check the array rank
+ CALL h5tget_array_ndims_f(mtid, ndims, error)
+ CALL check("h5tget_array_ndims_f", error, total_error)
+ CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
+
+ ! Get the array dimensions
+ CALL h5tget_array_dims_f(mtid, rdims1, error)
+ CALL check("h5tget_array_dims_f", error, total_error)
+
+ ! Check the array dimensions
+ DO i = 1, ndims
+ CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims2(i)), total_error)
+ ENDDO
+
+ ! Check the 3rd field's name
+ CALL H5Tget_member_name_f(tid2, 2, mname, namelen,error)
+ CALL check("H5Tget_member_name_f", error, total_error)
+ CALL verifystring("H5Tget_member_name_f",mname(1:namelen),"c", total_error)
+
+ ! Check the 3rd field's offset
+ CALL H5Tget_member_offset_f(tid2, 2, off, error)
+ CALL check("H5Tget_member_offset_f", error, total_error)
+ CALL VERIFY("H5Tget_member_offset_f",INT(off),&
+ H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%c(1))), total_error)
+
+ ! Check the 3rd field's datatype
+ CALL H5Tget_member_type_f(tid2, 2, mtid2, error)
+ CALL check("H5Tget_member_type_f", error, total_error)
+
+ ! Get the 3rd field's class
+ CALL H5Tget_class_f(mtid2, mclass, error)
+ CALL check("H5Tget_class_f", error, total_error)
+ CALL VERIFY("H5Tget_class_f",mclass, H5T_ARRAY_F, total_error)
+
+ ! Check the array rank
+ CALL h5tget_array_ndims_f(mtid2, ndims, error)
+ CALL check("h5tget_array_ndims_f", error, total_error)
+ CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
+
+ ! Get the array dimensions
+ CALL h5tget_array_dims_f(mtid2, rdims1, error)
+ CALL check("h5tget_array_dims_f", error, total_error)
+
+ ! Check the array dimensions
+ DO i = 1, ndims
+ CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims2(i)), total_error)
+ ENDDO
+
+ ! Check the nested array's datatype
+ CALL H5Tget_super_f(mtid, tid3, error)
+ CALL check("H5Tget_super_f", error, total_error)
+
+ CALL H5Tequal_f(tid3, H5T_NATIVE_REAL, flag, error)
+ CALL check("H5Tequal_f", error, total_error)
+ CALL VerifyLogical("H5Tequal_f", flag, .TRUE., total_error)
+
+ ! Check the nested array's datatype
+ CALL H5Tget_super_f(mtid2, tid3, error)
+ CALL check("H5Tget_super_f", error, total_error)
+
+ CALL H5Tequal_f(tid3, atype_id, flag, error)
+ CALL check("H5Tequal_f", error, total_error)
+ CALL VerifyLogical("H5Tequal_f", flag, .TRUE., total_error)
+
+ ! Close the array's base type datatype
+ CALL h5tclose_f(tid3, error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close the member datatype
+ CALL h5tclose_f(mtid,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close the member datatype
+ CALL h5tclose_f(mtid2,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close Compound Datatype
+ CALL h5tclose_f(tid2,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! READ dataset from disk
+
+ f_ptr = c_null_ptr
+ f_ptr = C_LOC(rdata(1,1))
+ CALL H5Dread_f(dataset, tid1, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+ ! Compare data read in
+ DO i = 1, SPACE1_DIM1
+ DO j = 1, ARRAY1_DIM1
+ IF(wdata(i,j)%i.NE.rdata(i,j)%i)THEN
+ PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ DO k = 1, ARRAY2_DIM1
+ IF(wdata(i,j)%f(k).NE.rdata(i,j)%f(k))THEN
+ PRINT*, 'ERROR: Wrong real array data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF(wdata(i,j)%c(k).NE.rdata(i,j)%c(k))THEN
+ PRINT*, 'ERROR: Wrong character array data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ! Close Datatype
+ CALL h5tclose_f(tid1,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ ! Close Dataset
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ ! Close file
+ CALL h5fclose_f(fid1,error)
+ CALL check("h5fclose_f", error, total_error)
+ END SUBROUTINE test_array_compound_array
+!!$
+!!$!***************************************************************
+!!$!**
+!!$!** test_array_bkg(): Test basic array datatype code.
+!!$!** Tests reading compound datatype with array fields and
+!!$!** writing partial fields.
+!!$!**
+!!$!***************************************************************
+!!$
+ SUBROUTINE test_array_bkg(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: r_k4 = SELECTED_REAL_KIND(5)
+ INTEGER, PARAMETER :: r_k8 = SELECTED_REAL_KIND(10)
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ INTEGER, PARAMETER :: LENGTH = 5
+ INTEGER, PARAMETER :: ALEN = 10
+ INTEGER, PARAMETER :: RANK = 1
+ INTEGER, PARAMETER :: NMAX = 100
+ CHARACTER(LEN=17), PARAMETER :: FIELDNAME = "ArrayofStructures"
+
+ INTEGER(hid_t) :: fid, array_dt
+ INTEGER(hid_t) :: space
+ INTEGER(hid_t) :: type
+ INTEGER(hid_t) :: dataset
+
+ INTEGER(hsize_t), DIMENSION(1:1) :: dim =(/LENGTH/)
+ INTEGER(hsize_t), DIMENSION(1:1) :: dima =(/ALEN/)
+
+ INTEGER :: i, j
+ INTEGER, DIMENSION(1:3) :: ndims = (/1,1,1/)
+
+ TYPE CmpField_struct
+ INTEGER, DIMENSION(1:ALEN) :: a
+ REAL(KIND=r_k4), DIMENSION(1:ALEN) :: b
+ REAL(KIND=r_k8), DIMENSION(1:ALEN) :: c
+ ENDTYPE CmpField_struct
+
+ TYPE(CmpField_struct), DIMENSION(1:LENGTH), TARGET :: cf
+ TYPE(CmpField_struct), DIMENSION(1:LENGTH), TARGET :: cfr
+
+ TYPE CmpDTSinfo_struct
+ INTEGER :: nsubfields
+ CHARACTER(LEN=5), DIMENSION(1:nmax) :: name
+ INTEGER(size_t), DIMENSION(1:nmax) :: offset
+ INTEGER(hid_t), DIMENSION(1:nmax) :: datatype
+ END TYPE CmpDTSinfo_struct
+
+ TYPE(CmpDTSinfo_struct) :: dtsinfo
+
+ TYPE fld_t_struct
+ REAL(KIND=r_k4), DIMENSION(1:ALEN) :: b
+ END TYPE fld_t_struct
+
+ INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
+ INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
+ INTEGER(SIZE_T) :: type_sized ! Size of the double datatype
+ INTEGER(SIZE_T) :: sizeof_compound ! total size of compound
+
+ TYPE(fld_t_struct), DIMENSION(1:LENGTH), TARGET :: fld
+ TYPE(fld_t_struct), DIMENSION(1:LENGTH), TARGET :: fldr
+
+ CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray3.h5"
+
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
+ INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims ! Array dimensions for reading
+
+ INTEGER :: error
+ TYPE(c_ptr) :: f_ptr
+
+ TYPE(c_funptr) :: func
+
+! Initialize the data
+! -------------------
+
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ cf(i)%a(j) = 100*(i+1) + j
+ cf(i)%b(j) = (100.*(i+1) + 0.01*j)
+ cf(i)%c(j) = 100.*(i+1) + 0.02*j
+ ENDDO
+ ENDDO
+
+ ! Set the number of data members
+ ! ------------------------------
+
+ dtsinfo%nsubfields = 3
+
+ ! Initialize the offsets
+ ! -----------------------
+ CALL h5tget_size_f(H5T_NATIVE_INTEGER, type_sizei, error)
+ CALL check("h5tget_size_f", error, total_error)
+ IF(sizeof(cf(1)%b(1)).EQ.4)THEN
+ CALL h5tget_size_f(H5T_NATIVE_REAL_4, type_sizer, error)
+ CALL check("h5tget_size_f", error, total_error)
+ ELSE IF(sizeof(cf(1)%b(1)).EQ.8)THEN
+ CALL h5tget_size_f(H5T_NATIVE_REAL_8, type_sizer, error)
+ CALL check("h5tget_size_f", error, total_error)
+ ENDIF
+
+ CALL h5tget_size_f(H5T_NATIVE_DOUBLE, type_sized, error)
+ CALL check("h5tget_size_f", error, total_error)
+
+ dtsinfo%offset(1) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%a(1)))
+ dtsinfo%offset(2) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%b(1)))
+ dtsinfo%offset(3) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%c(1)))
+
+
+ ! Initialize the data type IDs
+ ! ----------------------------
+ dtsinfo%datatype(1) = H5T_NATIVE_INTEGER;
+ dtsinfo%datatype(2) = H5T_NATIVE_REAL_4;
+ dtsinfo%datatype(3) = H5T_NATIVE_REAL_8;
+
+
+ ! Initialize the names of data members
+ ! ------------------------------------
+
+ dtsinfo%name(1) = "One "
+ dtsinfo%name(2) = "Two "
+ dtsinfo%name(3) = "Three"
+
+ ! Create file
+ ! -----------
+ CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid,error)
+ CALL check("h5fcreate_f", error, total_error)
+
+
+ ! Create data space
+ ! -----------------
+ CALL h5screate_simple_f(RANK, dim, space, error)
+ CALL check("h5screate_simple_f", error, total_error)
+
+
+ ! Create the memory data type
+ ! ---------------------------
+
+ CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(cf(1)), C_LOC(cf(2))), type, error)
+ CALL check("h5tcreate_f", error, total_error)
+
+ ! Add members to the compound data type
+ ! --------------------------------------
+
+ DO i = 1, dtsinfo%nsubfields
+ CALL h5tarray_create_f(dtsinfo%datatype(i), ndims(i), dima, array_dt, error)
+ CALL check("h5tarray_create_f", error, total_error)
+ CALL H5Tinsert_f(type, dtsinfo%name(i), dtsinfo%offset(i), array_dt, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ CALL h5tclose_f(array_dt,error)
+ CALL check("h5tclose_f", error, total_error)
+ ENDDO
+
+ ! Create the dataset
+ ! ------------------ /
+ CALL h5dcreate_f(fid,FIELDNAME,type, space, dataset,error)
+ CALL check("h5dcreate_f", error, total_error)
+
+ ! Write data to the dataset
+ ! -------------------------
+
+ ALLOCATE(rdims(1:2)) ! dummy not needed
+
+ f_ptr = C_LOC(cf(1))
+
+ CALL h5dwrite_f(dataset, type, f_ptr, error )
+ CALL check("h5dwrite_f", error, total_error)
+
+
+ ALLOCATE(rdims1(1:2)) ! dummy not needed
+ f_ptr = C_LOC(cfr(1))
+ CALL H5Dread_f(dataset, type, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+ ! Verify correct data
+ ! -------------------
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ IF( cf(i)%a(j) .NE. cfr(i)%a(j) )THEN
+ PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%b(j) .NE. cfr(i)%b(j) )THEN
+ PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%c(j) .NE. cfr(i)%c(j) )THEN
+ PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+
+ ! Release IDs
+ ! -----------
+ CALL h5tclose_f(type,error)
+ CALL check("h5tclose_f", error, total_error)
+ CALL h5sclose_f(space,error)
+ CALL check("h5sclose_f", error, total_error)
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+ CALL h5fclose_f(fid,error)
+ CALL check("h5fclose_f", error, total_error)
+
+ !****************************
+ ! Reopen the file and update
+ !****************************
+
+ CALL h5fopen_f (FILENAME, H5F_ACC_RDWR_F, fid, error)
+ CALL check("h5fopen_f", error, total_error)
+
+ CALL h5dopen_f(fid, FIELDNAME, dataset, error)
+ CALL check("h5dopen_f", error, total_error)
+
+ sizeof_compound = INT( type_sizer*ALEN, size_t)
+
+ CALL h5tcreate_f(H5T_COMPOUND_F, sizeof_compound , type, error)
+ CALL check("h5tcreate_f", error, total_error)
+
+ CALL h5tarray_create_f(H5T_NATIVE_REAL_4, 1, dima, array_dt, error)
+ CALL check("h5tarray_create_f", error, total_error)
+
+ CALL h5tinsert_f(TYPE, "Two", 0_size_t, array_dt, error)
+ CALL check("h5tinsert_f", error, total_error)
+
+ ! Initialize the data to overwrite
+ ! --------------------------------
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ fld(i)%b(j) = 1.313
+ cf(i)%b(j) = fld(i)%b(j)
+ ENDDO
+ ENDDO
+
+ f_ptr = C_LOC(fld(1))
+
+ CALL h5dwrite_f(dataset, TYPE, f_ptr, error )
+ CALL check("h5dwrite_f", error, total_error)
+
+
+ ! Read just the field changed
+
+ f_ptr = C_LOC(fldr(1))
+ CALL H5Dread_f(dataset, TYPE, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ IF( fld(i)%b(j) .NE. fldr(i)%b(j) )THEN
+ PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+ CALL h5tclose_f(TYPE,error)
+ CALL check("h5tclose_f", error, total_error)
+ CALL h5tclose_f(array_dt,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ CALL h5dget_type_f(dataset, type, error)
+ CALL check("h5dget_type_f", error, total_error)
+
+
+ ! Read the entire dataset again
+
+ f_ptr = C_LOC(cfr(1))
+ CALL H5Dread_f(dataset, TYPE, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+
+ ! Verify correct data
+ ! -------------------
+
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ IF( cf(i)%a(j) .NE. cfr(i)%a(j) )THEN
+ PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%b(j) .NE. cfr(i)%b(j) )THEN
+ PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%c(j) .NE. cfr(i)%c(j) )THEN
+ PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ CALL h5tclose_f(type,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ CALL h5fclose_f(fid,error)
+ CALL check("h5fclose_f", error, total_error)
+
+!**************************************************
+! Reopen the file and print out all the data again
+!**************************************************
+
+ CALL h5fopen_f (FILENAME, H5F_ACC_RDWR_F, fid, error)
+ CALL check("h5fopen_f", error, total_error)
+
+
+ CALL h5dopen_f(fid, FIELDNAME, dataset, error)
+ CALL check("h5dopen_f", error, total_error)
+
+
+ CALL h5dget_type_f(dataset, type, error)
+ CALL check("h5dget_type_f", error, total_error)
+
+
+ ! Reset the data to read in
+ ! -------------------------
+
+ DO i = 1, LENGTH
+ cfr(i)%a(:) = 0
+ cfr(i)%b(:) = 0
+ cfr(i)%c(:) = 0
+ ENDDO
+
+ f_ptr = C_LOC(cfr(1))
+ CALL H5Dread_f(dataset, TYPE, f_ptr, error)
+ CALL check("H5Dread_f", error, total_error)
+
+ ! Verify correct data
+ ! -------------------
+
+ DO i = 1, LENGTH
+ DO j = 1, ALEN
+ IF( cf(i)%a(j) .NE. cfr(i)%a(j) )THEN
+ PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%b(j) .NE. cfr(i)%b(j) )THEN
+ PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ IF( cf(i)%c(j) .NE. cfr(i)%c(j) )THEN
+ PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f '
+ total_error = total_error + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ CALL h5dclose_f(dataset, error)
+ CALL check("h5dclose_f", error, total_error)
+
+ CALL h5tclose_f(type,error)
+ CALL check("h5tclose_f", error, total_error)
+
+ CALL h5fclose_f(fid,error)
+ CALL check("h5fclose_f", error, total_error)
+
+ END SUBROUTINE test_array_bkg
+
+
+
+ SUBROUTINE test_h5kind_to_type(total_error)
+
+ USE ISO_C_BINDING
+ USE HDF5 ! This module contains all necessary modules
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ INTEGER, PARAMETER :: int_kind_1 = SELECTED_INT_KIND(Fortran_INTEGER_1) !should map to INTEGER*1 on most modern processors
+ INTEGER, PARAMETER :: int_kind_4 = SELECTED_INT_KIND(Fortran_INTEGER_2) !should map to INTEGER*2 on most modern processors
+ INTEGER, PARAMETER :: int_kind_8 = SELECTED_INT_KIND(Fortran_INTEGER_4) !should map to INTEGER*4 on most modern processors
+ INTEGER, PARAMETER :: int_kind_16 = SELECTED_INT_KIND(Fortran_INTEGER_8) !should map to INTEGER*8 on most modern processors
+
+ INTEGER, PARAMETER :: real_kind_7 = SELECTED_REAL_KIND(Fortran_REAL_4) !should map to REAL*4 on most modern processors
+ INTEGER, PARAMETER :: real_kind_15 = SELECTED_REAL_KIND(Fortran_REAL_8) !should map to REAL*8 on most modern processors
+
+ CHARACTER(LEN=8), PARAMETER :: filename = "dsetf.h5" ! File name
+ CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name
+ CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name
+ CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name
+ CHARACTER(LEN=5), PARAMETER :: dsetname8 = "dset8" ! Dataset name
+ CHARACTER(LEN=6), PARAMETER :: dsetnamer = "dsetr" ! Dataset name
+ CHARACTER(LEN=6), PARAMETER :: dsetnamer4 = "dsetr4" ! Dataset name
+ CHARACTER(LEN=6), PARAMETER :: dsetnamer8 = "dsetr8" ! Dataset name
+
+ INTEGER(HID_T) :: file_id ! File identifier
+ INTEGER(HID_T) :: dset_id1 ! Dataset identifier
+ INTEGER(HID_T) :: dset_id4 ! Dataset identifier
+ INTEGER(HID_T) :: dset_id8 ! Dataset identifier
+ INTEGER(HID_T) :: dset_id16 ! Dataset identifier
+ INTEGER(HID_T) :: dset_idr ! Dataset identifier
+ INTEGER(HID_T) :: dset_idr4 ! Dataset identifier
+ INTEGER(HID_T) :: dset_idr8 ! Dataset identifier
+
+ INTEGER :: error ! Error flag
+ INTEGER :: i, j
+
+! Data buffers:
+
+ INTEGER, DIMENSION(1:4) :: dset_data
+
+ INTEGER(int_kind_1), DIMENSION(1:4), TARGET :: dset_data_i1, data_out_i1
+ INTEGER(int_kind_4), DIMENSION(1:4), TARGET :: dset_data_i4, data_out_i4
+ INTEGER(int_kind_8), DIMENSION(1:4), TARGET :: dset_data_i8, data_out_i8
+ INTEGER(int_kind_16), DIMENSION(1:4), TARGET :: dset_data_i16, data_out_i16
+
+ REAL, DIMENSION(1:4), TARGET :: dset_data_r, data_out_r
+ REAL(real_kind_7), DIMENSION(1:4), TARGET :: dset_data_r7, data_out_r7
+ REAL(real_kind_15), DIMENSION(1:4), TARGET :: dset_data_r15, data_out_r15
+
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: data_dims = (/4/)
+ INTEGER(HID_T) :: dspace_id ! Dataspace identifier
+
+ TYPE(C_PTR) :: f_ptr
+ INTEGER(hid_t) :: datatype ! Common datatype ID
+
+ !
+ ! Initialize the dset_data array.
+ !
+ DO i = 1, 4
+ dset_data_i1(i) = i
+ dset_data_i4(i) = i
+ dset_data_i8(i) = i
+ dset_data_i16(i) = i
+
+ dset_data_r(i) = (i)*100.
+ dset_data_r7(i) = (i)*100.
+ dset_data_r15(i) = (i)*1000.
+
+ END DO
+
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create dataspaces for datasets
+ !
+ CALL h5screate_simple_f(1, data_dims , dspace_id, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset.
+ !
+ CALL H5Dcreate_f(file_id, dsetname1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), dspace_id, dset_id1, error)
+ CALL check("H5Dcreate_f",error, total_error)
+ CALL H5Dcreate_f(file_id, dsetname2, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), dspace_id, dset_id4, error)
+ CALL check("H5Dcreate_f",error, total_error)
+ CALL H5Dcreate_f(file_id, dsetname4, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), dspace_id, dset_id8, error)
+ CALL check("H5Dcreate_f",error, total_error)
+ CALL H5Dcreate_f(file_id, dsetname8, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), dspace_id, dset_id16, error)
+ CALL check("H5Dcreate_f",error, total_error)
+
+ CALL H5Dcreate_f(file_id, dsetnamer, H5T_NATIVE_REAL, dspace_id, dset_idr, error)
+ CALL check("H5Dcreate_f",error, total_error)
+ CALL H5Dcreate_f(file_id, dsetnamer4, h5kind_to_type(real_kind_7,H5_REAL_KIND), dspace_id, dset_idr4, error)
+ CALL check("H5Dcreate_f",error, total_error)
+ CALL H5Dcreate_f(file_id, dsetnamer8, h5kind_to_type(real_kind_15,H5_REAL_KIND), dspace_id, dset_idr8, error)
+ CALL check("H5Dcreate_f",error, total_error)
+
+ !
+ ! Write the dataset.
+ !
+ f_ptr = C_LOC(dset_data_i1(1))
+ CALL h5dwrite_f(dset_id1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_i4(1))
+ CALL h5dwrite_f(dset_id4, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_i8(1))
+ CALL h5dwrite_f(dset_id8, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_i16(1))
+ CALL h5dwrite_f(dset_id16, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_r(1))
+ CALL h5dwrite_f(dset_idr, H5T_NATIVE_REAL, f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_r7(1))
+ CALL h5dwrite_f(dset_idr4, h5kind_to_type(real_kind_7,H5_REAL_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ f_ptr = C_LOC(dset_data_r15(1))
+ CALL h5dwrite_f(dset_idr8, h5kind_to_type(real_kind_15,H5_REAL_KIND), f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ !
+ ! Close the file
+ !
+ CALL h5fclose_f(file_id, error)
+ CALL check("h5fclose_f",error, total_error)
+
+ ! Open the file
+
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file_id, error)
+ CALL check("h5fopen_f",error, total_error)
+ !
+ ! Read the dataset.
+ !
+ ! Read data back into an integer size that is larger then the original size used for
+ ! writing the data
+ f_ptr = C_LOC(data_out_i1)
+ CALL h5dread_f(dset_id1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_i4)
+ CALL h5dread_f(dset_id4, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_i8)
+ CALL h5dread_f(dset_id8, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_i16)
+ CALL h5dread_f(dset_id16, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_r)
+ CALL h5dread_f(dset_idr, H5T_NATIVE_REAL, f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_r7)
+ CALL h5dread_f(dset_idr4, h5kind_to_type(real_kind_7,H5_REAL_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+ f_ptr = C_LOC(data_out_r15)
+ CALL h5dread_f(dset_idr8, h5kind_to_type(real_kind_15,H5_REAL_KIND), f_ptr, error)
+ CALL check("h5dread_f",error, total_error)
+
+ DO i = 1, 4
+
+ CALL verify_Fortran_INTEGER_4("h5kind_to_type1",INT(dset_data_i1(i),int_kind_8),INT(data_out_i1(i),int_kind_8),total_error)
+ CALL verify_Fortran_INTEGER_4("h5kind_to_type2",INT(dset_data_i4(i),int_kind_8),INT(data_out_i4(i),int_kind_8),total_error)
+ CALL verify_Fortran_INTEGER_4("h5kind_to_type3",INT(dset_data_i8(i),int_kind_8),INT(data_out_i8(i),int_kind_8),total_error)
+ CALL verify_Fortran_INTEGER_4("h5kind_to_type4",INT(dset_data_i16(i),int_kind_8),INT(data_out_i16(i),int_kind_8),total_error)
+
+ CALL verify_real_kind_7("h5kind_to_type5",REAL(dset_data_r(i),real_kind_7),REAL(data_out_r(i),real_kind_7),total_error)
+ CALL verify_real_kind_7("h5kind_to_type6",REAL(dset_data_r7(i),real_kind_7),REAL(data_out_r7(i),real_kind_7),total_error)
+ CALL verify_real_kind_7("h5kind_to_type7",REAL(dset_data_r15(i),real_kind_7),REAL(data_out_r15(i),real_kind_7),total_error)
+
+ END DO
+
+ !
+ ! Close the dataset.
+ !
+ CALL h5dclose_f(dset_id1, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset_id4, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset_id8, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset_id16, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset_idr4, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset_idr8, error)
+ CALL check("h5dclose_f",error, total_error)
+ !
+ ! Close the file.
+ !
+ CALL h5fclose_f(file_id, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE test_h5kind_to_type
+
+!************************************************************
+!
+! This test reads and writes array datatypes
+! to a dataset. The test first writes integers arrays of
+! dimension ADIM0xADIM1 to a dataset with a dataspace of
+! DIM0, then closes the file. Next, it reopens the file,
+! reads back the data.
+!
+!************************************************************
+SUBROUTINE t_array(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ CHARACTER(LEN=19), PARAMETER :: filename = "t_array_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 4
+ INTEGER , PARAMETER :: adim0 = 3
+ INTEGER , PARAMETER :: adim1 = 5
+ INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
+ INTEGER :: hdferr
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: adims = (/adim0, adim1/)
+ INTEGER(HSIZE_T), DIMENSION(1:3) :: bdims = (/dim0, adim0, adim1/)
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
+ INTEGER, DIMENSION(1:dim0, 1:adim0, 1:adim1), TARGET :: wdata ! Write buffer
+ INTEGER, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+ INTEGER :: i, j, k
+ TYPE(C_PTR) :: f_ptr
+ INTEGER :: error ! Error flag
+
+ !
+ ! Initialize data. i is the element in the dataspace, j and k the
+ ! elements within the array datatype.
+ !
+ DO i = 1, dim0
+ DO j = 1, adim0
+ DO k = 1, adim1
+ wdata(i,j,k) = (i-1)*(j-1)-(j-1)*(k-1)+(i-1)*(k-1)
+ ENDDO
+ ENDDO
+ ENDDO
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, error)
+ !
+ ! Create array datatypes for file and memory.
+ !
+ CALL H5Tarray_create_f(INT(H5T_STD_I64LE, HID_T), 2, adims, filetype, error)
+ CALL check("H5Tarray_create_f",error, total_error)
+ CALL H5Tarray_create_f(H5T_NATIVE_INTEGER, 2, adims, memtype, error)
+ CALL check("H5Tarray_create_f",error, total_error)
+ !
+ ! Create dataspace. Setting maximum size to be the current size.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the array data to it.
+ !
+ CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata)
+ CALL h5dwrite_f(dset, memtype, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file, dataset, and attribute.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get the datatype and its dimensions.
+ !
+ CALL h5dget_type_f(dset, filetype, error)
+ CALL check("h5dget_type_f",error, error)
+ CALL H5Tget_array_dims_f(filetype, adims, error)
+ CALL check("h5dget_type_f",error, total_error)
+ CALL VERIFY("H5Tget_array_dims_f", INT(adims(1)), adim0, total_error)
+ CALL VERIFY("H5Tget_array_dims_f", INT(adims(2)), adim1, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer. This is a
+ ! three dimensional attribute when the array datatype is included.
+ !
+ CALL H5Dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, error)
+ CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+
+ ALLOCATE(rdata(1:dims(1),1:adims(1),1:adims(2)))
+ !
+ ! Create the memory datatype.
+ !
+ CALL H5Tarray_create_f(H5T_NATIVE_INTEGER, 2, adims, memtype, error)
+ CALL check("H5Tarray_create_f",error, total_error)
+ !
+ ! Read the data.
+ !
+
+ f_ptr = C_LOC(rdata)
+ CALL H5Dread_f(dset, memtype, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+ !
+ ! Output the data to the screen.
+ !
+ i_loop: DO i = 1, dims(1)
+ DO j=1, adim0
+ DO k = 1, adim1
+ CALL VERIFY("H5Sget_simple_extent_dims_f", rdata(i,j,k), wdata(i,j,k), total_error)
+ IF(total_error.NE.0) EXIT i_loop
+ ENDDO
+ ENDDO
+ ENDDO i_loop
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_array
+
+SUBROUTINE t_enum(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ CHARACTER(LEN=19), PARAMETER :: filename = "t_enum_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 4
+ INTEGER , PARAMETER :: dim1 = 7
+ INTEGER(HID_T) :: F_BASET ! File base type
+ INTEGER(HID_T) :: M_BASET ! Memory base type
+ INTEGER(SIZE_T) , PARAMETER :: NAME_BUF_SIZE = 16
+
+! Enumerated type
+ INTEGER, PARAMETER :: SOLID=0, LIQUID=1, GAS=2, PLASMA=3
+
+ INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
+
+ INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/dim0, dim1/)
+ INTEGER, DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
+ INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+ INTEGER, DIMENSION(1:1), TARGET :: val
+
+ CHARACTER(LEN=6), DIMENSION(1:4) :: &
+ names = (/"SOLID ", "LIQUID", "GAS ", "PLASMA"/)
+ CHARACTER(LEN=NAME_BUF_SIZE) :: name
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
+ INTEGER :: i, j, idx
+ TYPE(C_PTR) :: f_ptr
+ INTEGER :: error ! Error flag
+ !
+ ! Initialize DATA.
+ !
+ F_BASET = H5T_STD_I16BE ! File base type
+ M_BASET = H5T_NATIVE_INTEGER ! Memory base type
+ DO i = 1, dim0
+ DO j = 1, dim1
+ wdata(i,j) = MOD( (j-1)*(i-1), PLASMA+1)
+ ENDDO
+ ENDDO
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create the enumerated datatypes for file and memory. This
+ ! process is simplified IF native types are used for the file,
+ ! as only one type must be defined.
+ !
+ CALL h5tenum_create_f(F_BASET, filetype, error)
+ CALL check("h5tenum_create_f",error, total_error)
+
+ CALL h5tenum_create_f(M_BASET, memtype, error)
+ CALL check("h5tenum_create_f",error, total_error)
+
+ DO i = SOLID, PLASMA
+ !
+ ! Insert enumerated value for memtype.
+ !
+ val(1) = i
+ CALL H5Tenum_insert_f(memtype, TRIM(names(i+1)), val(1), error)
+ CALL check("H5Tenum_insert_f", error, total_error)
+ !
+ ! Insert enumerated value for filetype. We must first convert
+ ! the numerical value val to the base type of the destination.
+ !
+ f_ptr = C_LOC(val(1))
+ CALL H5Tconvert_f(M_BASET, F_BASET, INT(1,SIZE_T), f_ptr, error)
+ CALL check("H5Tconvert_f",error, total_error)
+ CALL H5Tenum_insert_f(filetype, TRIM(names(i+1)), val(1), error)
+ CALL check("H5Tenum_insert_f",error, total_error)
+ ENDDO
+ !
+ ! Create dataspace. Setting maximum size to be the current size.
+ !
+ CALL h5screate_simple_f(2, dims, space, total_error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the enumerated data to it.
+ !
+ CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata(1,1))
+ CALL h5dwrite_f(dset, memtype, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL h5tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f (file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL h5dget_space_f(dset,space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(2)), dim1, total_error)
+
+ ALLOCATE(rdata(1:dims(1),1:dims(2)))
+
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1,1))
+ CALL h5dread_f(dset, memtype, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+
+ !
+ ! Output the data to the screen.
+ !
+ i_loop: DO i = 1, dims(1)
+ DO j = 1, dims(2)
+ !
+ ! Get the name of the enumeration member.
+ !
+ CALL h5tenum_nameof_f( memtype, rdata(i,j), NAME_BUF_SIZE, name, error)
+ CALL check("h5tenum_nameof_f",error, total_error)
+ idx = MOD( (j-1)*(i-1), PLASMA+1 ) + 1
+ CALL verifystring("h5tenum_nameof_f",TRIM(name),TRIM(names(idx)), total_error)
+ IF(total_error.NE.0) EXIT i_loop
+ ENDDO
+ ENDDO i_loop
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL h5tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_enum
+
+SUBROUTINE t_bit(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ CHARACTER(LEN=20), PARAMETER :: filename = "t_bit_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 4
+ INTEGER , PARAMETER :: dim1 = 7
+
+ INTEGER(HID_T) :: file, space, dset ! Handles
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/dim0, dim1/)
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
+ INTEGER(C_SIGNED_CHAR), DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
+ INTEGER(C_SIGNED_CHAR), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+ INTEGER :: A, B, C, D
+ INTEGER :: Aw, Bw, Cw, Dw
+ INTEGER :: i, j
+ INTEGER, PARAMETER :: hex = Z'00000003'
+ TYPE(C_PTR) :: f_ptr
+ INTEGER :: error ! Error flag
+ !
+ ! Initialize data. We will manually pack 4 2-bit integers into
+ ! each unsigned char data element.
+ !
+ DO i = 0, dim0-1
+ DO j = 0, dim1-1
+ wdata(i+1,j+1) = 0
+ wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(IAND(i * j - j, hex),C_SIGNED_CHAR) ) ! Field "A"
+ wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(i,hex),2),C_SIGNED_CHAR) ) ! Field "B"
+ wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(j,hex),4),C_SIGNED_CHAR) ) ! Field "C"
+ wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(i+j,hex),6),C_SIGNED_CHAR) ) ! Field "D"
+ ENDDO
+ ENDDO
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create dataspace. Setting maximum size to be the current size.
+ !
+ CALL h5screate_simple_f(2, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the bitfield data to it.
+ !
+ CALL H5Dcreate_f(file, dataset, H5T_STD_B8BE, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata(1,1))
+ CALL H5Dwrite_f(dset, H5T_NATIVE_B8, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file, dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL H5Dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(2)), dim1, total_error)
+ ALLOCATE(rdata(1:dims(1),1:dims(2)))
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata)
+ CALL H5Dread_f(dset, H5T_NATIVE_B8, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+ !
+ ! Output the data to the screen.
+ !
+ i_loop: DO i = 1, dims(1)
+ DO j = 1, dims(2)
+ A = IAND(rdata(i,j), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "A"
+ B = IAND(ISHFT(rdata(i,j),-2), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "B"
+ C = IAND(ISHFT(rdata(i,j),-4), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "C"
+ D = IAND(ISHFT(rdata(i,j),-6), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "D"
+
+ Aw = IAND(wdata(i,j), INT(hex,C_SIGNED_CHAR))
+ Bw = IAND(ISHFT(wdata(i,j),-2), INT(hex,C_SIGNED_CHAR))
+ Cw = IAND(ISHFT(wdata(i,j),-4), INT(hex,C_SIGNED_CHAR))
+ Dw = IAND(ISHFT(wdata(i,j),-6), INT(hex,C_SIGNED_CHAR))
+
+ CALL VERIFY("bitfield", A, Aw, total_error)
+ CALL VERIFY("bitfield", B, Bw, total_error)
+ CALL VERIFY("bitfield", C, Cw, total_error)
+ CALL VERIFY("bitfield", D, Dw, total_error)
+ IF(total_error.NE.0) EXIT i_loop
+ ENDDO
+ ENDDO i_loop
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_bit
+
+SUBROUTINE t_opaque(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ CHARACTER(LEN=20), PARAMETER :: filename = "t_opaque_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 4
+ INTEGER(SIZE_T) , PARAMETER :: size = 7
+ INTEGER(HID_T) :: file, space, dtype, dset ! Handles
+ INTEGER(size_t) :: len
+ INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/DIM0/)
+
+ CHARACTER(LEN=size), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
+ CHARACTER(LEN=size), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+ CHARACTER(LEN=size-1) :: str = "OPAQUE"
+
+ CHARACTER(LEN=14) :: tag_sm ! Test reading obaque tag into
+ CHARACTER(LEN=15) :: tag_exact ! buffers that are: to small, exact
+ CHARACTER(LEN=17) :: tag_big ! and to big.
+
+ INTEGER :: taglen
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
+ INTEGER :: i
+ CHARACTER(LEN=1) :: ichr
+ TYPE(C_PTR) :: f_ptr
+ INTEGER :: error
+ !
+ ! Initialize data.
+ !
+ DO i = 1, dim0
+ WRITE(ichr,'(I1)') i-1
+ wdata(i) = str//ichr
+ ENDDO
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create opaque datatype and set the tag to something appropriate.
+ ! For this example we will write and view the data as a character
+ ! array.
+ !
+ CALL h5tcreate_f(h5T_OPAQUE_F, size, dtype, error)
+ CALL check("h5tcreate_f",error, total_error)
+ CALL h5tset_tag_f(dtype,"Character array",error)
+ CALL check("h5tset_tag_f",error, total_error)
+ !
+ ! Create dataspace. Setting maximum size to be the current size.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the opaque data to it.
+ !
+ CALL h5dcreate_f(file, dataset, dtype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata(1))
+ CALL h5dwrite_f(dset, dtype, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(dtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get datatype and properties for the datatype.
+ !
+ CALL h5dget_type_f(dset, dtype, error)
+ CALL check("h5dget_type_f",error, total_error)
+ CALL h5tget_size_f(dtype, len, error)
+ CALL check("h5tget_size_f",error, total_error)
+
+ ! Next tests should return
+ ! opaque_tag = tag = "Character array" and the actual length = 15
+
+ ! Test reading into a string that is to small
+ CALL h5tget_tag_f(dtype, tag_sm, taglen, error)
+ CALL check("h5tget_tag_f",error, total_error)
+ CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
+ CALL verifystring("h5tget_tag_f",tag_sm,"Character arra", total_error)
+
+ ! Test reading into a string that is exact
+ CALL h5tget_tag_f(dtype, tag_exact, taglen, error)
+ CALL check("h5tget_tag_f",error, total_error)
+ CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
+ CALL verifystring("h5tget_tag_f",tag_exact,"Character array", total_error)
+
+ ! Test reading into a string that is to big
+ CALL h5tget_tag_f(dtype, tag_big, taglen, error)
+ CALL check("h5tget_tag_f",error, total_error)
+ CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
+ CALL verifystring("h5tget_tag_f",tag_big,"Character array ", total_error)
+
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL h5dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+ ALLOCATE(rdata(1:dims(1)))
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1))
+ CALL h5dread_f(dset, dtype, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+ !
+ DO i = 1, dims(1)
+ CALL verifystring("t_opaque",TRIM(rdata(i)),TRIM(wdata(i)), total_error)
+ ENDDO
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(dtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_opaque
+
+SUBROUTINE t_objref(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ CHARACTER(LEN=20), PARAMETER :: filename = "t_objref_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 2
+
+ INTEGER(HID_T) :: file, space, dset, obj ! Handles
+ INTEGER :: error
+
+ INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/dim0/)
+ TYPE(hobj_ref_t_f), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
+ TYPE(hobj_ref_t_f), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+ INTEGER :: objtype
+ INTEGER(SIZE_T) :: name_size
+ CHARACTER(LEN=80) :: name
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
+ INTEGER :: i
+ TYPE(C_PTR) :: f_ptr
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create a dataset with a null dataspace.
+ !
+ CALL h5screate_f(H5S_NULL_F,space,error)
+ CALL check("h5screate_f",error, total_error)
+ CALL h5dcreate_f(file, "DS2", H5T_STD_I32LE, space, obj, error)
+ CALL check("h5dcreate_f",error, total_error)
+ !
+ CALL h5dclose_f(obj , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ !
+ ! Create a group.
+ !
+ CALL h5gcreate_f(file, "G1", obj, error)
+ CALL check("h5gcreate_f",error, total_error)
+ CALL h5gclose_f(obj, error)
+ CALL check("h5gclose_f",error, total_error)
+ !
+ ! Create references to the previously created objects. note, space_id
+ ! is not needed for object references.
+ !
+ f_ptr = C_LOC(wdata(1))
+ CALL H5Rcreate_f(file, "G1", H5R_OBJECT_F, f_ptr, error)
+ CALL check("H5Rcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata(2))
+ CALL H5Rcreate_f(file, "DS2", H5R_OBJECT_F, f_ptr, error)
+ CALL check("H5Rcreate_f",error, total_error)
+ !
+ ! Create dataspace. Setting maximum size to be the current size.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the object references to it.
+ !
+ CALL h5dcreate_f(file, dataset, H5T_STD_REF_OBJ, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+
+ f_ptr = C_LOC(wdata(1))
+ CALL h5dwrite_f(dset, H5T_STD_REF_OBJ, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL h5dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+
+ ALLOCATE(rdata(1:maxdims(1)))
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1))
+ CALL h5dread_f( dset, H5T_STD_REF_OBJ, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+ !
+ ! Output the data to the screen.
+ !
+ DO i = 1, maxdims(1)
+ !
+ ! Open the referenced object, get its name and type.
+ !
+ f_ptr = C_LOC(rdata(i))
+ CALL H5Rdereference_f(dset, H5R_OBJECT_F, f_ptr, obj, error)
+ CALL check("H5Rdereference_f",error, total_error)
+ CALL H5Rget_obj_type_f(dset, H5R_OBJECT_F, f_ptr, objtype, error)
+ CALL check("H5Rget_obj_type_f",error, total_error)
+ !
+ ! Get the length of the name and name
+ !
+ CALL H5Iget_name_f(obj, name, 80_size_t, name_size, error)
+ CALL check("H5Iget_name_f",error, total_error)
+ !
+ ! Print the object type and close the object.
+ !
+ IF(objtype.EQ.H5G_GROUP_F)THEN
+ CALL verifystring("t_objref", name(1:name_size),"/G1", total_error)
+ ELSE IF(objtype.EQ.H5G_DATASET_F)THEN
+ CALL verifystring("t_objref", name(1:name_size),"/DS2", total_error)
+ ELSE
+ total_error = total_error + 1
+ ENDIF
+ CALL h5oclose_f(obj, error)
+ CALL check("h5oclose_f",error, total_error)
+
+ END DO
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_objref
+
+
+SUBROUTINE t_regref(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ CHARACTER(LEN=22), PARAMETER :: filename = "t_regref_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ CHARACTER(LEN=3) , PARAMETER :: dataset2 = "DS2"
+ INTEGER , PARAMETER :: dim0 = 2
+ INTEGER , PARAMETER :: ds2dim0 = 16
+ INTEGER , PARAMETER :: ds2dim1 = 3
+
+ INTEGER(HID_T) :: file, memspace, space, dset, dset2 ! Handles
+ INTEGER :: error
+
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: dims3
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: dims2 = (/ds2dim0,ds2dim1/)
+
+ INTEGER(HSIZE_T), DIMENSION(1:2,1:4) :: coords = RESHAPE((/2,1,12,3,1,2,5,3/),(/2,4/))
+
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: start=(/0,0/),stride=(/11,2/),count=(/2,2/), BLOCK=(/3,1/)
+
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
+ INTEGER(hssize_t) :: npoints
+ TYPE(hdset_reg_ref_t_f), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
+ TYPE(hdset_reg_ref_t_f), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
+
+ INTEGER(size_t) :: size
+ CHARACTER(LEN=1), DIMENSION(1:ds2dim0,1:ds2dim1), TARGET :: wdata2
+
+ CHARACTER(LEN=80),DIMENSION(1:1), TARGET :: rdata2
+ CHARACTER(LEN=80) :: name
+ INTEGER :: i
+ TYPE(C_PTR) :: f_ptr
+ CHARACTER(LEN=ds2dim0) :: chrvar
+ CHARACTER(LEN=20), DIMENSION(1:2) :: chrref_correct
+
+ chrvar = "The quick brown "
+ READ(chrvar,'(16A1)') wdata2(1:16,1)
+ chrvar = "fox jumps over "
+ READ(chrvar,'(16A1)') wdata2(1:16,2)
+ chrvar = "the 5 lazy dogs "
+ READ(chrvar,'(16A1)') wdata2(1:16,3)
+
+ chrref_correct(1) = 'hdf5'
+ chrref_correct(2) = 'Therowthedog'
+
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create a dataset with character data.
+ !
+ CALL h5screate_simple_f(2, dims2, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ CALL h5dcreate_f(file,dataset2, H5T_STD_I8LE, space, dset2, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata2(1,1))
+ CALL h5dwrite_f(dset2, H5T_NATIVE_INTEGER_1, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Create reference to a list of elements in dset2.
+ !
+ CALL h5sselect_elements_f(space, H5S_SELECT_SET_F, 2, INT(4,size_t), coords, error)
+ CALL check("h5sselect_elements_f",error, total_error)
+ f_ptr = C_LOC(wdata(1))
+ CALL h5rcreate_f(file, DATASET2, H5R_DATASET_REGION_F, f_ptr, error, space)
+ CALL check("h5rcreate_f",error, total_error)
+ !
+ ! Create reference to a hyperslab in dset2, close dataspace.
+ !
+ CALL h5sselect_hyperslab_f (space, H5S_SELECT_SET_F, start, count, error, stride, block)
+ CALL check("h5sselect_hyperslab_f",error, total_error)
+ f_ptr = C_LOC(wdata(2))
+ CALL h5rcreate_f(file, DATASET2, H5R_DATASET_REGION_F, f_ptr, error, space)
+ CALL check("h5rcreate_f",error, total_error)
+
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ !
+ ! Create dataspace. Setting maximum size to the current size.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+
+ !
+ ! Create the dataset and write the region references to it.
+ !
+ CALL h5dcreate_f(file, dataset, H5T_STD_REF_DSETREG, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+ f_ptr = C_LOC(wdata(1))
+ CALL h5dwrite_f(dset, H5T_STD_REF_DSETREG, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5dclose_f(dset2, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+ !
+ ! Now we begin the read section of this example.
+ !
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL h5dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+ ALLOCATE(rdata(1:dims(1)))
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1))
+ CALL h5dread_f( dset, H5T_STD_REF_DSETREG, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+ !
+ ! Output the data to the screen.
+ !
+ DO i = 1, dims(1)
+
+ !
+ ! Open the referenced object, retrieve its region as a
+ ! dataspace selection.
+ !
+ CALL H5Rdereference_f(dset, rdata(i), dset2, error)
+ CALL check("H5Rdereference_f",error, total_error)
+
+ CALL H5Rget_region_f(dset, rdata(i), space, error)
+ CALL check("H5Rget_region_f",error, total_error)
+
+ !
+ ! Get the object's name
+ !
+ CALL H5Iget_name_f(dset2, name, 80_size_t, size, error)
+ CALL check("H5Iget_name_f",error, total_error)
+ CALL VERIFY("H5Iget_name_f", size, LEN_TRIM(name), total_error)
+ CALL verifystring("H5Iget_name_f",name(1:size),TRIM(name), total_error)
+ !
+ ! Allocate space for the read buffer.
+ !
+ CALL H5Sget_select_npoints_f(space, npoints, error)
+ CALL check("H5Sget_select_npoints_f",error, total_error)
+ CALL VERIFY("H5Sget_select_npoints_f", INT(npoints), LEN_TRIM(chrref_correct(i)), total_error)
+
+ dims3(1) = npoints
+ !
+ ! Read the dataset region.
+ !
+ CALL h5screate_simple_f(1, dims3, memspace, error)
+ CALL check("h5screate_simple_f",error, total_error)
+
+ f_ptr = C_LOC(rdata2(1))
+ CALL h5dread_f( dset2, H5T_NATIVE_INTEGER_1, f_ptr, error, memspace, space)
+ CALL check("H5Dread_f",error, total_error)
+ CALL verifystring("h5dread_f",rdata2(1)(1:npoints),TRIM(chrref_correct(i)), total_error)
+
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Sclose_f(memspace, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Dclose_f(dset2, error)
+ CALL check("h5dclose_f",error, total_error)
+
+ END DO
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(rdata)
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_regref
+
+SUBROUTINE t_vlen(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+ CHARACTER(LEN=18), PARAMETER :: filename = "t_vlen_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER, PARAMETER :: LEN0 = 3
+ INTEGER, PARAMETER :: LEN1 = 12
+ INTEGER :: dim0
+
+ INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
+ INTEGER :: error
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
+ INTEGER :: i, j
+
+ ! vl data
+ TYPE vl
+ INTEGER, DIMENSION(:), POINTER :: DATA
+ END TYPE vl
+ TYPE(vl), DIMENSION(:), ALLOCATABLE, TARGET :: ptr
+
+
+ TYPE(hvl_t), DIMENSION(1:2), TARGET :: wdata ! Array of vlen structures
+ TYPE(hvl_t), DIMENSION(1:2), TARGET :: rdata ! Pointer to vlen structures
+
+ INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/2/)
+ INTEGER, DIMENSION(:), POINTER :: ptr_r
+ TYPE(C_PTR) :: f_ptr
+
+ !
+ ! Initialize variable-length data. wdata(1) is a countdown of
+ ! length LEN0, wdata(2) is a Fibonacci sequence of length LEN1.
+ !
+ wdata(1)%len = LEN0
+ wdata(2)%len = LEN1
+
+ ALLOCATE( ptr(1:2) )
+ ALLOCATE( ptr(1)%data(1:wdata(1)%len) )
+ ALLOCATE( ptr(2)%data(1:wdata(2)%len) )
+
+ DO i=1, wdata(1)%len
+ ptr(1)%data(i) = wdata(1)%len - i + 1 ! 3 2 1
+ ENDDO
+ wdata(1)%p = C_LOC(ptr(1)%data(1))
+
+ ptr(2)%data(1:2) = 1
+ DO i = 3, wdata(2)%len
+ ptr(2)%data(i) = ptr(2)%data(i-1) + ptr(2)%data(i-2) ! (1 1 2 3 5 8 etc.)
+ ENDDO
+ wdata(2)%p = C_LOC(ptr(2)%data(1))
+
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create variable-length datatype for file and memory.
+ !
+ CALL H5Tvlen_create_f(H5T_STD_I32LE, filetype, error)
+ CALL check("H5Tvlen_create_f",error, total_error)
+ CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, error)
+ CALL check("H5Tvlen_create_f",error, total_error)
+ !
+ ! Create dataspace.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the variable-length data to it.
+ !
+ CALL H5Dcreate_f(file, dataset, filetype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+
+ f_ptr = C_LOC(wdata(1))
+ CALL h5dwrite_f(dset, memtype, f_ptr, error)
+ CALL check("h5dwrite_f",error, total_error)
+ !
+ ! Close and release resources. Note the use of H5Dvlen_reclaim
+ ! removes the need to manually deallocate the previously allocated
+ ! data.
+ !
+
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+ !
+ ! Now we begin the read section of this example.
+
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+
+ !
+ ! Get dataspace and allocate memory for array of vlen structures.
+ ! This does not actually allocate memory for the vlen data, that
+ ! will be done by the library.
+ !
+ CALL H5Dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ dim0 = dims(1)
+ CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+
+ !
+ ! Create the memory datatype.
+ !
+ CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, error)
+ CALL check("H5Tvlen_create_f",error, total_error)
+
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1))
+ CALL H5Dread_f(dset, memtype, f_ptr, error)
+ CALL check("H5Dread_f",error, total_error)
+
+ DO i = 1, dims(1)
+ CALL c_f_pointer(rdata(i)%p, ptr_r, [rdata(i)%len] )
+ DO j = 1, rdata(i)%len
+ CALL VERIFY("t_vlen", ptr_r(j), ptr(i)%data(j), total_error)
+ ENDDO
+ ENDDO
+ !
+ ! Close and release resources.
+ !
+ DEALLOCATE(ptr)
+ CALL h5dvlen_reclaim_f(memtype, space, H5P_DEFAULT_F, f_ptr, error)
+ CALL h5dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_vlen
+
+
+SUBROUTINE t_vlstring(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ CHARACTER(LEN=18), PARAMETER :: filename = "t_vlstring.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+
+ INTEGER(SIZE_T), PARAMETER :: dim0 = 4
+ INTEGER(SIZE_T), PARAMETER :: sdim = 7
+ INTEGER(HID_T) :: file, filetype, space, dset ! Handles
+ INTEGER :: error
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
+ INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
+
+ CHARACTER(LEN=sdim), DIMENSION(1:dim0), TARGET :: &
+ wdata = (/"Parting", "is such", "sweet ", "sorrow."/) ! Write buffer
+ CHARACTER(LEN=sdim), DIMENSION(:), ALLOCATABLE :: rdata ! Read buffer
+ INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/sdim,dim0/)
+ INTEGER(SIZE_T), DIMENSION(4) :: str_len = (/7,7,5,7/)
+ INTEGER :: i
+
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create file and memory datatypes. For this example we will save
+ ! the strings as C variable length strings, H5T_STRING is defined
+ ! as a variable length string.
+ !
+ CALL H5Tcopy_f(H5T_STRING, filetype, error)
+ CALL check("H5Tcopy_f",error, total_error)
+ CALL H5Tset_strpad_f(filetype, H5T_STR_NULLPAD_F, error)
+ CALL check("H5Tset_strpad_f",error, total_error)
+ !
+ ! Create dataspace.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the variable-length string data to
+ ! it.
+ !
+ CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+
+ CALL h5dwrite_vl_f(dset, filetype, wdata, data_dims, str_len, error, space)
+ CALL check("h5dwrite_vl_f",error, total_error)
+
+ !
+ ! Close and release resources.
+ !
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+ !
+ ! Now we begin the read section of this example.
+ !
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get the datatype.
+ !
+ CALL H5Dget_type_f(dset, filetype, error)
+ CALL check("H5Dget_type_f",error, total_error)
+ !
+ ! Get dataspace and allocate memory for read buffer.
+ !
+ CALL H5Dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+
+ ALLOCATE(rdata(1:dims(1)))
+
+ !
+ ! Read the data.
+ !
+ CALL h5dread_vl_f(dset, filetype, rdata, data_dims, str_len, error, space)
+ CALL check("H5Dread_vl_f",error, total_error)
+
+ !
+ ! Output the data to the screen.
+ !
+ DO i = 1, dims(1)
+ CALL verifystring("h5dopen_f",TRIM(rdata(i)),TRIM(wdata(i)) , total_error)
+ END DO
+
+ DEALLOCATE(rdata)
+ CALL h5dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+
+END SUBROUTINE t_vlstring
+
+
+SUBROUTINE t_string(total_error)
+
+ USE HDF5
+ USE ISO_C_BINDING
+
+ IMPLICIT NONE
+
+ INTEGER, INTENT(INOUT) :: total_error
+
+ CHARACTER(LEN=20), PARAMETER :: filename = "t_string_F03.h5"
+ CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
+ INTEGER , PARAMETER :: dim0 = 4
+ INTEGER(SIZE_T) , PARAMETER :: sdim = 8
+
+ INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
+ INTEGER :: error
+
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
+ INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
+
+ CHARACTER(LEN=sdim), DIMENSION(1:dim0), TARGET :: &
+ wdata = (/"Parting", "is such", "sweet ", "sorrow."/)
+ CHARACTER(LEN=sdim), DIMENSION(:), ALLOCATABLE, TARGET :: rdata
+ INTEGER :: i
+ INTEGER(SIZE_T) :: size
+ TYPE(C_PTR) :: f_ptr
+ !
+ ! Create a new file using the default properties.
+ !
+ CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
+ CALL check("h5fcreate_f",error, total_error)
+ !
+ ! Create file datatypes. For this example we will save
+ ! the strings as FORTRAN strings
+ !
+ CALL H5Tcopy_f(H5T_FORTRAN_S1, filetype, error)
+ CALL check("H5Tcopy_f",error, total_error)
+ CALL H5Tset_size_f(filetype, sdim, error)
+ CALL check("H5Tset_size_f",error, total_error)
+ !
+ ! Create dataspace.
+ !
+ CALL h5screate_simple_f(1, dims, space, error)
+ CALL check("h5screate_simple_f",error, total_error)
+ !
+ ! Create the dataset and write the string data to it.
+ !
+ CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
+ CALL check("h5dcreate_f",error, total_error)
+
+ f_ptr = C_LOC(wdata(1)(1:1))
+ CALL H5Dwrite_f(dset, filetype, f_ptr, error)
+ CALL check("H5Dwrite_f",error, total_error)
+ !
+ ! Close and release resources.
+ !
+ CALL h5dclose_f(dset , error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL h5sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(filetype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL h5fclose_f(file , error)
+ CALL check("h5fclose_f",error, total_error)
+ !
+ ! Now we begin the read section of this example.
+ !
+ ! Open file and dataset.
+ !
+ CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
+ CALL check("h5fopen_f",error, total_error)
+ CALL h5dopen_f(file, dataset, dset, error)
+ CALL check("h5dopen_f",error, total_error)
+ !
+ ! Get the datatype and its size.
+ !
+ CALL H5Dget_type_f(dset, filetype, error)
+ CALL check("H5Dget_type_f",error, total_error)
+ CALL H5Tget_size_f(filetype, size, error)
+ CALL check("H5Tget_size_f",error, total_error)
+ CALL VERIFY("H5Tget_size_f", size, sdim, total_error)
+ !
+ ! Get dataspace.
+ !
+ CALL H5Dget_space_f(dset, space, error)
+ CALL check("H5Dget_space_f",error, total_error)
+ CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
+ CALL check("H5Sget_simple_extent_dims_f",error, total_error)
+ CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), dim0, total_error)
+
+ ALLOCATE(rdata(1:dims(1)))
+ !
+ ! Create the memory datatype.
+ !
+ CALL H5Tcopy_f(H5T_FORTRAN_S1, memtype, error)
+ CALL check("H5Tcopy_f",error, total_error)
+ CALL H5Tset_size_f(memtype, sdim, error)
+ CALL check("H5Tset_size_f",error, total_error)
+ !
+ ! Read the data.
+ !
+ f_ptr = C_LOC(rdata(1)(1:1))
+ CALL H5Dread_f(dset, memtype, f_ptr, error, space)
+ CALL check("H5Dread_f",error, total_error)
+
+ DO i = 1, dims(1)
+ CALL verifystring("h5dopen_f",TRIM(rdata(i)),TRIM(wdata(i)) , total_error)
+ END DO
+
+ DEALLOCATE(rdata)
+
+ !
+ ! Close and release resources.
+ !
+ CALL H5Dclose_f(dset, error)
+ CALL check("h5dclose_f",error, total_error)
+ CALL H5Sclose_f(space, error)
+ CALL check("h5sclose_f",error, total_error)
+ CALL H5Tclose_f(memtype, error)
+ CALL check("h5tclose_f",error, total_error)
+ CALL H5Fclose_f(file, error)
+ CALL check("h5fclose_f",error, total_error)
+
+
+END SUBROUTINE t_string
+
+
diff --git a/fortran/test/tH5VL.f90 b/fortran/test/tH5VL.f90
index 3afd025..85feb2b 100644
--- a/fortran/test/tH5VL.f90
+++ b/fortran/test/tH5VL.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5VL.f90
+!
+! NAME
+! tH5VL.f90
+!
+! FUNCTION
+! Basic testing of Fortran Variable_length datatypes APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,12 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! vl_test_integer, vl_test_real, vl_test_string
!
-!
-! Testing Variable_length datatypes
-!
-!
-!
+!*****
+
SUBROUTINE vl_test_integer(cleanup, total_error)
USE HDF5 ! This module contains all necessary modules
@@ -105,7 +113,8 @@
CALL check("h5dwrite_int_f", error, total_error)
- !
+
+ !
! End access to the dataset and release resources used by it.
!
CALL h5dclose_f(dset_id, error)
@@ -154,7 +163,6 @@
endif
enddo
-
!
CALL h5dclose_f(dset_id, error)
CALL check("h5dclose_f", error, total_error)
diff --git a/fortran/test/tH5Z.f90 b/fortran/test/tH5Z.f90
index 6262528..cd6a343 100644
--- a/fortran/test/tH5Z.f90
+++ b/fortran/test/tH5Z.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tH5Z.f90
+!
+! NAME
+! tH5Z.f90
+!
+! FUNCTION
+! Basic testing of Fortran H5Z szip APIs.
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,6 +22,11 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! filters_test, szip_test
+!
+!*****
+
SUBROUTINE filters_test(cleanup, total_error)
! This subroutine tests following functionalities: h5zfilter_avail_f, h5zunregister_f
diff --git a/fortran/test/tf.f90 b/fortran/test/tf.f90
index 51c9410..d5c32c8 100644
--- a/fortran/test/tf.f90
+++ b/fortran/test/tf.f90
@@ -1,3 +1,12 @@
+!****h* root/fortran/test/tf.f90
+!
+! NAME
+! tf.f90
+!
+! FUNCTION
+! Contains subroutines which are needed in all the hdf5 fortran tests
+!
+! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! Copyright by The HDF Group. *
! Copyright by the Board of Trustees of the University of Illinois. *
@@ -13,12 +22,29 @@
! access to either file, you may request a copy from help@hdfgroup.org. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
+! CONTAINS SUBROUTINES
+! write_test_status, check, verify, verifyLogical, verifyString, h5_fixname_f,
+! h5_cleanup_f, h5_exit_f, h5_env_nocleanup_f
!
-!
-! This file contains subroutines which are used in
-! all the hdf5 fortran tests
-!
+!*****
+!This definition is needed for Windows DLLs
+!DEC$if defined(BUILD_HDF5_DLL)
+!DEC$attributes dllexport :: verify_real
+!DEC$endif
+SUBROUTINE verify_real_kind_7(string,value,correct_value,total_error)
+ USE HDF5
+
+ INTEGER, PARAMETER :: real_kind_7 = SELECTED_REAL_KIND(Fortran_REAL_4) !should map to REAL*4 on most modern processors
+ CHARACTER(LEN=*) :: string
+ REAL(real_kind_7) :: value, correct_value
+ INTEGER :: total_error
+ IF (value .NE. correct_value) THEN
+ total_error=total_error+1
+ WRITE(*,*) "ERROR: INCORRECT REAL VALIDATION ", string
+ ENDIF
+ RETURN
+END SUBROUTINE verify_real_kind_7
!This definition is needed for Windows DLLs
!DEC$if defined(BUILD_HDF5_DLL)
@@ -77,7 +103,7 @@ END SUBROUTINE check
!DEC$if defined(BUILD_HDF5_DLL)
!DEC$attributes dllexport :: verify
!DEC$endif
-SUBROUTINE VERIFY(string,value,correct_value,total_error)
+SUBROUTINE verify(string,value,correct_value,total_error)
CHARACTER(LEN=*) :: string
INTEGER :: value, correct_value, total_error
IF (value .NE. correct_value) THEN
@@ -89,6 +115,25 @@ END SUBROUTINE verify
!This definition is needed for Windows DLLs
!DEC$if defined(BUILD_HDF5_DLL)
+!DEC$attributes dllexport :: verify
+!DEC$endif
+SUBROUTINE verify_Fortran_INTEGER_4(string,value,correct_value,total_error)
+ USE HDF5
+ INTEGER, PARAMETER :: int_kind_8 = SELECTED_INT_KIND(Fortran_INTEGER_4) ! should map to INTEGER*4 on most modern processors
+ CHARACTER(LEN=*) :: string
+ INTEGER(int_kind_8) :: 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_Fortran_INTEGER_4
+
+
+
+
+!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)
@@ -106,16 +151,16 @@ END SUBROUTINE verifyLogical
!DEC$if defined(BUILD_HDF5_DLL)
!DEC$attributes dllexport :: verifyString
!DEC$endif
-SUBROUTINE verifyString(string, value,correct_value,total_error)
- CHARACTER(LEN=*) :: string
- CHARACTER(LEN=*) :: value, correct_value
+SUBROUTINE verifystring(string, value,correct_value,total_error)
+ CHARACTER*(*) :: string
+ CHARACTER*(*) :: 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
+END SUBROUTINE verifystring
!----------------------------------------------------------------------