summaryrefslogtreecommitdiffstats
path: root/fortran/test/tH5L_F03.f90
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/tH5L_F03.f90
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/tH5L_F03.f90')
-rw-r--r--fortran/test/tH5L_F03.f90334
1 files changed, 334 insertions, 0 deletions
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