1! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
2! * Copyright by The HDF Group.                                               *
3! * Copyright by the Board of Trustees of the University of Illinois.         *
4! * All rights reserved.                                                      *
5! *                                                                           *
6! * This file is part of HDF5.  The full HDF5 copyright notice, including     *
7! * terms governing use, modification, and redistribution, is contained in    *
8!   the COPYING file, which can be found at the root of the source code       *
9!   distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases.  *
10!   If you do not have access to either file, you may request a copy from     *
11!   help@hdfgroup.org.                                                        *
12! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
13
14MODULE TSTDS
15
16CONTAINS
17
18!-------------------------------------------------------------------------
19! test_begin
20!-------------------------------------------------------------------------
21
22SUBROUTINE test_begin(string)
23  CHARACTER(LEN=*), INTENT(IN) :: string
24  WRITE(*, fmt = '(A)', advance = 'no') ADJUSTL(string)
25END SUBROUTINE test_begin
26
27!-------------------------------------------------------------------------
28! passed/failed
29!-------------------------------------------------------------------------
30SUBROUTINE write_test_status( test_result)
31
32! Writes the results of the tests
33
34  IMPLICIT NONE
35
36  INTEGER, INTENT(IN) :: test_result  ! negative,   failed
37                                      ! 0       ,   passed
38
39! Controls the output style for reporting test results
40
41  CHARACTER(LEN=8) :: error_string
42  CHARACTER(LEN=8), PARAMETER :: success = ' PASSED '
43  CHARACTER(LEN=8), PARAMETER :: failure = '*FAILED*'
44
45  error_string = failure
46  IF (test_result .EQ.  0) THEN
47     error_string = success
48  ENDIF
49
50  WRITE(*, fmt = '(T34, A)') error_string
51
52END SUBROUTINE write_test_status
53
54END MODULE TSTDS
55
56MODULE TSTDS_TESTS
57
58CONTAINS
59
60SUBROUTINE test_testds(err)
61
62  USE HDF5
63  USE H5LT
64  USE H5DS
65  USE TSTDS ! module for testing dataset support routines
66
67  IMPLICIT NONE
68
69  INTEGER, PARAMETER :: RANK      = 2 ! rank of DATA dataset
70  INTEGER, PARAMETER :: DIM_DATA  = 12
71  INTEGER, PARAMETER :: DIM1_SIZE = 3
72  INTEGER, PARAMETER :: DIM2_SIZE = 4
73  INTEGER, PARAMETER :: DIM1      = 1
74  INTEGER, PARAMETER :: DIM2      = 2
75  INTEGER, PARAMETER :: FAILED    = -1
76
77  CHARACTER(LEN=6), PARAMETER :: DSET_NAME = "Mydata"
78  CHARACTER(LEN=5), PARAMETER :: DS_1_NAME = "Yaxis"
79  CHARACTER(LEN=5), PARAMETER :: DS_2_NAME = "Xaxis"
80
81
82  INTEGER(hid_t) :: fid    ! file ID
83  INTEGER(hid_t) :: did    ! dataset ID
84  INTEGER(hid_t) :: dsid   ! DS dataset ID
85  INTEGER :: rankds = 1    ! rank of DS dataset
86  INTEGER(hsize_t), DIMENSION(1:rank) ::  dims  = (/DIM2_SIZE,DIM1_SIZE/) ! size of DATA dataset
87  INTEGER, DIMENSION(1:DIM_DATA) :: buf = (/1,2,3,4,5,6,7,8,9,10,11,12/)  ! DATA of DATA dataset
88  INTEGER(hsize_t), DIMENSION(1:1) ::  s1_dim  = (/DIM1_SIZE/)  ! size of DS 1 dataset
89  INTEGER(hsize_t), DIMENSION(1:1) ::  s2_dim  = (/DIM2_SIZE/)  ! size of DS 2 dataset
90  REAL, DIMENSION(1:DIM1_SIZE) ::   s1_wbuf = (/10,20,30/)     ! DATA of DS 1 dataset
91  INTEGER, DIMENSION(1:DIM2_SIZE) :: s2_wbuf = (/10,20,50,100/) ! DATA of DS 2 dataset
92  INTEGER :: err
93  INTEGER :: num_scales
94  INTEGER(size_t) :: name_len
95  CHARACTER(LEN=80) :: name
96  INTEGER(size_t) :: label_len
97  CHARACTER(LEN=80) :: label
98  LOGICAL :: is_attached, is_scale
99
100  !
101  ! Initialize FORTRAN predefined datatypes.
102  !
103  CALL h5open_f(err)
104  IF(err.LT.0) RETURN
105
106  ! create a file using default properties
107  CALL H5Fcreate_f("tstds.h5",H5F_ACC_TRUNC_F, fid, err)
108  IF(err.LT.0) RETURN
109
110  ! make a dataset
111  CALL H5LTmake_dataset_int_f(fid,DSET_NAME,rank,dims,buf, err)
112  IF(err.LT.0) RETURN
113
114  ! make a DS dataset for the first dimension
115  CALL H5LTmake_dataset_float_f(fid,DS_1_NAME,rankds,s1_dim,s1_wbuf,err)
116  IF(err.LT.0) RETURN
117
118  ! make a DS dataset for the second dimension
119  CALL H5LTmake_dataset_int_f(fid,DS_2_NAME,rankds,s2_dim,s2_wbuf,err)
120  IF(err.LT.0) RETURN
121
122  !-------------------------------------------------------------------------
123  ! attach the DS_1_NAME dimension scale to DSET_NAME at dimension 1
124  !-------------------------------------------------------------------------
125
126  CALL test_begin(' Test Attaching Dimension Scale         ')
127
128  ! get the dataset id for DSET_NAME
129  CALL H5Dopen_f(fid, DSET_NAME, did, err)
130  IF(err.LT.0) RETURN
131
132  ! get the DS dataset id
133  CALL H5Dopen_f(fid, DS_1_NAME, dsid, err)
134  IF(err.LT.0) RETURN
135
136  ! check attaching to a non-existent dimension; should fail
137  CALL H5DSattach_scale_f(did, dsid, 20, err)
138  IF(err.NE.-1) THEN
139     err = FAILED ! should fail, mark as an error
140     CALL write_test_status(err)
141     RETURN
142  ENDIF
143
144  ! attach the DS_1_NAME dimension scale to DSET_NAME at dimension index 1
145  CALL H5DSattach_scale_f(did, dsid, DIM1, err)
146  IF(err.EQ.-1) THEN
147     CALL write_test_status(err)
148     RETURN
149  ENDIF
150  CALL write_test_status(err)
151
152  CALL test_begin(' Test If Dimension Scale Attached       ')
153
154  CALL H5DSis_attached_f(did, dsid, DIM1, is_attached, err)
155  IF(err.EQ.-1.OR..NOT.is_attached) THEN
156     err = FAILED
157     CALL write_test_status(err)
158     RETURN
159  ENDIF
160  CALL write_test_status(err)
161
162  ! Check to see how many Dimension Scales are attached
163
164  CALL test_begin(' Test Getting Number Dimension Scales   ')
165
166  CALL H5DSget_num_scales_f(did, DIM1, num_scales, err)
167  IF(err.LT.0.OR.num_scales.NE.1)THEN
168     err = FAILED
169     CALL write_test_status(err)
170     RETURN
171  ENDIF
172  CALL write_test_status(err)
173
174  CALL test_begin(' Test Detaching Dimension Scale         ')
175
176  ! Detach scale
177  CALL H5DSdetach_scale_f(did, dsid, DIM1, err)
178  IF(err.LT.0) RETURN
179
180  ! Check to see if a dimension scale is attached, should be .false.
181  CALL H5DSis_attached_f(did, dsid, DIM1, is_attached, err)
182  IF(err.LT.0.OR.is_attached)THEN
183     err = FAILED
184     CALL write_test_status(err)
185     RETURN
186  ENDIF
187  CALL write_test_status(err)
188
189  !-------------------------------------------------------------------------
190  ! set the DS_1_NAME dimension scale to DSET_NAME at dimension 0
191  !-------------------------------------------------------------------------
192
193  CALL test_begin(' Test Setting Dimension Scale           ')
194
195  CALL H5DSset_scale_f(dsid, err, "Dimension Scale Set 1")
196  IF(err.LT.0.OR.is_attached)THEN
197     err = FAILED
198     CALL write_test_status(err)
199     RETURN
200  ENDIF
201  CALL write_test_status(err)
202
203  CALL test_begin(' Test If Dimension Scale                ')
204
205  CALL H5DSis_scale_f(dsid, is_scale, err)
206  IF(err.LT.0.OR..NOT.is_scale)THEN
207     err = FAILED
208     CALL write_test_status(err)
209     RETURN
210  ENDIF
211  CALL write_test_status(err)
212
213  ! Get scale name; test to large character buffer
214
215  CALL test_begin(' Test Getting Dimension Scale By Name   ')
216
217  name_len = 25
218  name = ''
219  CALL H5DSget_scale_name_f(dsid, name, name_len, err)
220  IF(err.LT.0 .OR. &
221       name_len.NE.21 .OR. &
222       TRIM(name).NE."Dimension Scale Set 1" .OR. &
223       name(22:25).NE.'   ')THEN
224     err = FAILED
225     CALL write_test_status(err)
226     RETURN
227  ENDIF
228
229  ! Get scale name; test exact size character buffer
230  name_len = 21
231  name = ''
232  CALL H5DSget_scale_name_f(dsid, name(1:name_len), name_len, err)
233  IF(err.LT.0.OR.name_len.NE.21.OR.TRIM(name).NE."Dimension Scale Set 1")THEN
234     err = FAILED
235     CALL write_test_status(err)
236     RETURN
237  ENDIF
238
239  ! Get scale name; test to small character buffer
240  name_len = 5
241  name = ''
242  CALL H5DSget_scale_name_f(dsid, name(1:name_len), name_len, err)
243  IF(err.LT.0.OR.name_len.NE.21.OR.TRIM(name).NE."Dimen")THEN
244     err = FAILED
245     CALL write_test_status(err)
246     RETURN
247  ENDIF
248
249  ! close DS id
250  CALL H5Dclose_f(dsid, err)
251  IF(err.LT.0) RETURN
252
253  !-------------------------------------------------------------------------
254  ! attach the DS_2_NAME dimension scale to DSET_NAME
255  !-------------------------------------------------------------------------
256
257  ! get the DS dataset id
258  CALL H5Dopen_f(fid, DS_2_NAME, dsid, err)
259  IF(err.LT.0) RETURN
260
261  ! attach the DS_2_NAME dimension scale to DSET_NAME as the 2nd dimension (index 2)
262  CALL H5DSattach_scale_f(did, dsid, DIM2, err)
263  IF(err.LT.0) RETURN
264
265  CALL H5DSis_attached_f(did, dsid, DIM2, is_attached, err)
266  IF(err.LT.0) RETURN
267
268  ! test sending no Dimension Scale name
269
270  CALL H5DSset_scale_f(dsid, err)
271  IF(err.LT.0)THEN
272     CALL write_test_status(err)
273     RETURN
274  ENDIF
275
276  CALL H5DSis_scale_f(dsid, is_scale, err)
277  IF(err.LT.0.OR..NOT.is_scale)THEN
278     err = FAILED
279     CALL write_test_status(err)
280     RETURN
281  ENDIF
282
283  ! Get scale name when there is no scale name
284  name_len = 5
285  name = ''
286  CALL H5DSget_scale_name_f(dsid, name(1:name_len), name_len, err)
287  IF(err.LT.0.OR.name_len.NE.0)THEN ! name_len is 0 if no name is found
288     err = FAILED
289     CALL write_test_status(err)
290     RETURN
291  ENDIF
292
293  CALL write_test_status(err)
294
295  CALL test_begin(' Test Setting Dimension Scale Label     ')
296
297  CALL H5DSset_label_f(did, DIM2, "Label12", err)
298  IF(err.LT.0)THEN
299     CALL write_test_status(err)
300     RETURN
301  ENDIF
302
303  ! Test label where character length is to small
304
305  label_len = 5
306  label = ''
307  CALL H5DSget_label_f(did, DIM2, label(1:label_len), label_len, err)
308  IF(err.LT.0.OR.label(1:5).NE."Label".OR.label_len.NE.7)THEN
309     err = FAILED
310     CALL write_test_status(err)
311     RETURN
312  ENDIF
313
314  ! Test label where character length is exact
315
316  label_len = 7
317  label = ''
318  CALL H5DSget_label_f(did, DIM2, label(1:label_len), label_len, err)
319  IF(err.LT.0.OR.label(1:label_len).NE."Label12".OR.label_len.NE.7)THEN
320     err = FAILED
321     CALL write_test_status(err)
322     RETURN
323  ENDIF
324
325  ! Test label where character length is to big
326
327  label_len = 25
328  label = ''
329  CALL H5DSget_label_f(did, DIM2, label, label_len, err)
330  IF(err.LT.0.OR. &
331       label(1:label_len).NE."Label12" .OR. &
332       label_len.NE.7 .OR. &
333       label(8:25).NE.'                  ')THEN
334     err = FAILED
335     CALL write_test_status(err)
336     RETURN
337  ENDIF
338  CALL write_test_status(err)
339
340 ! close DS id
341  CALL H5Dclose_f(dsid, err)
342  IF(err.LT.0) RETURN
343
344 ! close file
345  CALL H5Fclose_f(fid, err)
346  IF(err.LT.0) RETURN
347
348END SUBROUTINE test_testds
349
350END MODULE TSTDS_TESTS
351
352PROGRAM test_ds
353
354  USE TSTDS_TESTS ! module for testing dataset routines
355
356  IMPLICIT NONE
357
358  INTEGER :: err
359
360  CALL test_testds(err)
361
362  IF(err.LT.0)THEN
363     WRITE(*,'(5X,A)') "DIMENSION SCALES TEST *FAILED*"
364  ENDIF
365
366END PROGRAM test_ds
367
368