1!****h* root/fortran/test/tH5L_F03.f90
2!
3! NAME
4!  tH5L_F03.f90
5!
6! FUNCTION
7!  Test FORTRAN HDF5 H5L APIs which are dependent on FORTRAN 2003
8!  features.
9!
10! COPYRIGHT
11! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
12!   Copyright by The HDF Group.                                               *
13!   Copyright by the Board of Trustees of the University of Illinois.         *
14!   All rights reserved.                                                      *
15!                                                                             *
16!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
17!   terms governing use, modification, and redistribution, is contained in    *
18!   the COPYING file, which can be found at the root of the source code       *
19!   distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases.  *
20!   If you do not have access to either file, you may request a copy from     *
21!   help@hdfgroup.org.                                                        *
22! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
23!
24! USES
25!  liter_cb_mod
26!
27! CONTAINS SUBROUTINES
28!  test_iter_group
29!
30!*****
31MODULE liter_cb_mod
32
33  USE HDF5
34  USE TH5_MISC
35  USE TH5_MISC_GEN
36  USE, INTRINSIC :: ISO_C_BINDING
37  IMPLICIT NONE
38
39  TYPE iter_enum
40     INTEGER RET_ZERO
41     INTEGER RET_TWO
42     INTEGER RET_CHANGE
43     INTEGER RET_CHANGE2
44  END TYPE iter_enum
45
46  ! Custom group iteration callback data
47  TYPE, bind(c) ::  iter_info
48     CHARACTER(KIND=C_CHAR), DIMENSION(1:10) :: name !  The name of the object
49     INTEGER(c_int) :: TYPE    !  The TYPE of the object
50     INTEGER(c_int) :: command ! The TYPE of RETURN value
51  END TYPE iter_info
52
53CONTAINS
54
55!***************************************************************
56!**
57!**  liter_cb(): Custom link iteration callback routine.
58!**
59!***************************************************************
60
61  INTEGER(KIND=C_INT) FUNCTION liter_cb(group, name, link_info, op_data) bind(C)
62
63    IMPLICIT NONE
64
65    INTEGER(HID_T), VALUE :: group
66    CHARACTER(LEN=1), DIMENSION(1:10) :: name
67
68
69    TYPE (H5L_info_t) :: link_info
70
71    TYPE(iter_info) :: op_data
72
73    INTEGER, SAVE :: count
74    INTEGER, SAVE :: count2
75
76!!$
77!!$    iter_info *info = (iter_info *)op_data;
78!!$    static int count = 0;
79!!$    static int count2 = 0;
80
81    op_data%name(1:10) = name(1:10)
82
83    SELECT CASE (op_data%command)
84
85    CASE(0)
86       liter_cb = 0
87    CASE(2)
88       liter_cb = 2
89    CASE(3)
90       count = count + 1
91       IF(count.GT.10) THEN
92          liter_cb = 1
93       ELSE
94          liter_cb = 0
95       ENDIF
96    CASE(4)
97       count2 = count2 + 1
98       IF(count2.GT.10) THEN
99          liter_cb = 1
100       ELSE
101          liter_cb = 0
102       ENDIF
103    END SELECT
104
105  END FUNCTION liter_cb
106END MODULE liter_cb_mod
107
108MODULE TH5L_F03
109
110CONTAINS
111
112! *****************************************
113! ***        H 5 L   T E S T S
114! *****************************************
115
116
117!***************************************************************
118!**
119!**  test_iter_group(): Test group iteration functionality
120!**
121!***************************************************************
122SUBROUTINE test_iter_group(total_error)
123
124  USE liter_cb_mod
125  IMPLICIT NONE
126
127  INTEGER, INTENT(INOUT) :: total_error
128  INTEGER(HID_T) :: fapl
129  INTEGER(HID_T) :: file             !  File ID
130  INTEGER(hid_t) :: dataset          ! Dataset ID
131  INTEGER(hid_t) :: datatype         ! Common datatype ID
132  INTEGER(hid_t) :: filespace        ! Common dataspace ID
133  INTEGER(hid_t) :: grp              ! Group ID
134  INTEGER i,j                        ! counting variable
135  INTEGER(hsize_t) idx               ! Index in the group
136  CHARACTER(LEN=11) :: DATAFILE = "titerate.h5"
137  INTEGER, PARAMETER :: ndatasets = 50
138  CHARACTER(LEN=10) :: name !  temporary name buffer
139  CHARACTER(LEN=10), DIMENSION(1:ndatasets+2) :: lnames !  Names of the links created
140
141  TYPE(iter_info), TARGET :: info
142
143  INTEGER :: error
144  INTEGER :: ret_value
145  TYPE(C_FUNPTR) :: f1
146  TYPE(C_PTR) :: f2
147  CHARACTER(LEN=2) :: ichr2
148  CHARACTER(LEN=10) :: ichr10
149
150  ! Get the default FAPL
151  CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
152  CALL check("h5pcreate_f", error, total_error)
153
154  ! Set the "use the latest version of the format" bounds for creating objects in the file
155  CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error)
156  CALL check("H5Pset_libver_bounds_f",error, total_error)
157
158  ! Create the test file with the datasets
159  CALL h5fcreate_f(DATAFILE, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl)
160  CALL check("h5fcreate_f", error, total_error)
161
162  ! Test iterating over empty group
163  idx = 0
164  info%command = 0
165  f1 = C_FUNLOC(liter_cb)
166  f2 = C_LOC(info)
167
168
169  CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
170  CALL check("H5Literate_f", error, total_error)
171
172  CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
173  CALL check("H5Tcopy_f", error, total_error)
174
175  CALL H5Screate_f(H5S_SCALAR_F, filespace, error)
176  CALL check("H5Screate_f", error, total_error)
177
178  DO i = 1, ndatasets
179     WRITE(ichr2, '(I2.2)') i
180
181     name = 'Dataset '//ichr2
182
183     CALL h5dcreate_f(file, name, datatype, filespace, dataset, error)
184     CALL check("H5dcreate_f", error, total_error)
185
186     lnames(i) = name
187
188     CALL h5dclose_f(dataset,error)
189     CALL check("H5dclose_f", error, total_error)
190
191  ENDDO
192
193  !  Create a group and named datatype under root group for testing
194
195  CALL H5Gcreate_f(file, "grp0000000", grp, error)
196  CALL check("H5Gcreate_f", error, total_error)
197
198  lnames(ndatasets+2) = "grp0000000"
199
200!!$
201!!$    lnames[NDATASETS] = HDstrdup("grp");
202!!$    CHECK(lnames[NDATASETS], NULL, "strdup");
203!!$
204
205  CALL H5Tcommit_f(file, "dtype00000", datatype, error)
206  CALL check("H5Tcommit_f", error, total_error)
207
208  lnames(ndatasets+1) = "dtype00000"
209
210  !  Close everything up
211
212  CALL H5Tclose_f(datatype, error)
213  CALL check("H5Tclose_f", error, total_error)
214
215  CALL H5Gclose_f(grp, error)
216  CALL check("H5Gclose_f", error, total_error)
217
218  CALL H5Sclose_f(filespace, error)
219  CALL check("H5Sclose_f", error, total_error)
220
221  CALL H5Fclose_f(file, error)
222  CALL check("H5Fclose_f", error, total_error)
223
224  !  Iterate through the datasets in the root group in various ways
225  CALL H5Fopen_f(DATAFILE, H5F_ACC_RDONLY_F, file, error, access_prp=fapl)
226  CALL check("h5fopen_f", error, total_error)
227
228  ! Test all objects in group, when callback always returns 0
229  info%command = 0
230  idx = 0
231  CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
232  IF(ret_value.GT.0)THEN
233     PRINT*,"ERROR: Group iteration function didn't return zero correctly!"
234     CALL verify("H5Literate_f", error, -1, total_error)
235  ENDIF
236
237  !   Test all objects in group, when callback always returns 1
238  !   This also tests the "restarting" ability, because the index changes
239
240  info%command = 2
241  idx = 0
242  i = 0
243  f1 = C_FUNLOC(liter_cb)
244  f2 = C_LOC(info)
245  DO
246     CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
247     IF(error.LT.0) EXIT
248     !  Verify return value from iterator gets propagated correctly
249     CALL verify("H5Literate", ret_value, 2, total_error)
250     !  Increment the number of times "2" is returned
251     i = i + 1
252     ! Verify that the index is the correct value
253     CALL verify("H5Literate", INT(idx), INT(i), total_error)
254     IF(idx .GT.ndatasets+2)THEN
255        PRINT*,"ERROR: Group iteration function walked too far!"
256     ENDIF
257
258     ! Verify the correct name is retrieved
259     DO j = 1, 10
260        ichr10(j:j) = info%name(j)(1:1)
261     ENDDO
262     CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
263     IF(i.EQ.52)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIXME- scot
264  END DO
265
266  ! put check if did not walk far enough -scot FIXME
267
268  IF(i .NE. (NDATASETS + 2)) THEN
269     CALL verify("H5Literate_f", i, INT(NDATASETS + 2), total_error)
270     PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly"
271  ENDIF
272
273  ! Test all objects in group, when callback changes return value
274  ! This also tests the "restarting" ability, because the index changes
275
276  info%command = 3
277  idx = 0
278  i = 0
279
280  f1 = C_FUNLOC(liter_cb)
281  f2 = C_LOC(info)
282  DO
283
284     CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
285     IF(error.LT.0) EXIT
286     CALL verify("H5Literate_f", ret_value, 1, total_error)
287
288     ! Increment the number of times "1" is returned
289     i = i + 1
290
291     ! Verify that the index is the correct value
292     CALL verify("H5Literate_f", INT(idx), INT(i+10), total_error)
293
294     IF(idx .GT.ndatasets+2)THEN
295        PRINT*,"Group iteration function walked too far!"
296     ENDIF
297
298     DO j = 1, 10
299        ichr10(j:j) = info%name(j)(1:1)
300     ENDDO
301     ! Verify that the correct name is retrieved
302     CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
303     IF(i.EQ.42)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIX- scot
304  ENDDO
305
306  IF(i .NE. 42 .OR. idx .NE. 52)THEN
307     PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly!"
308     CALL check("H5Literate_f",-1,total_error)
309  ENDIF
310
311  CALL H5Fclose_f(file, error)
312  CALL check("H5Fclose_f", error, total_error)
313
314END SUBROUTINE test_iter_group
315
316END MODULE TH5L_F03
317