Line data Source code
1 : !> HDF5 backend — read/write hsd_table trees using the HDF5 Fortran API.
2 : !>
3 : !> Mapping (per SPECIFICATION.md §3.5):
4 : !> hsd_table → HDF5 group
5 : !> hsd_value (string) → HDF5 variable-length string dataset
6 : !> hsd_value (integer) → HDF5 scalar/1-D integer dataset
7 : !> hsd_value (real) → HDF5 scalar/1-D real dataset
8 : !> hsd_value (logical) → HDF5 integer dataset (0/1)
9 : !> hsd_value (complex) → HDF5 compound type {re, im}
10 : !> hsd_value (array) → HDF5 1-D dataset
11 : !> Matrix → HDF5 2-D dataset
12 : !> node%attrib → HDF5 string attribute on group/dataset
13 : !>
14 : !> Requires HDF5 Fortran bindings. Compiled only when WITH_HDF5 is defined.
15 : module hsd_data_hdf5
16 : use hdf5, only: hid_t, hsize_t, size_t, &
17 : & h5open_f, h5close_f, &
18 : & h5fcreate_f, h5fopen_f, h5fclose_f, h5f_acc_trunc_f, h5f_acc_rdonly_f, &
19 : & h5gcreate_f, h5gopen_f, h5gclose_f, h5gn_members_f, h5gget_obj_info_idx_f, &
20 : & h5g_group_f, h5g_dataset_f, &
21 : & h5dcreate_f, h5dopen_f, h5dclose_f, h5dread_f, h5dwrite_f, &
22 : & h5dget_space_f, h5dget_type_f, &
23 : & h5screate_f, h5screate_simple_f, h5sclose_f, &
24 : & h5sget_simple_extent_ndims_f, h5sget_simple_extent_dims_f, &
25 : & h5s_scalar_f, &
26 : & h5tcopy_f, h5tcreate_f, h5tclose_f, h5tinsert_f, &
27 : & h5tset_size_f, h5tget_class_f, h5tget_size_f, h5tget_nmembers_f, &
28 : & h5t_native_integer, h5t_native_double, h5t_fortran_s1, &
29 : & h5t_integer_f, h5t_float_f, h5t_string_f, h5t_compound_f, &
30 : & h5acreate_f, h5aopen_f, h5aclose_f, h5aread_f, h5awrite_f, &
31 : & h5aexists_f, h5aget_type_f
32 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_node_ptr, hsd_error_t, &
33 : & new_table, new_value, hsd_clone, dp, &
34 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
35 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
36 : & VALUE_TYPE_COMPLEX, HSD_STAT_IO_ERROR
37 : implicit none(type, external)
38 : private
39 :
40 : public :: hdf5_backend_load, hdf5_backend_dump
41 :
42 : contains
43 :
44 : ! ===========================================================================
45 : ! Writer (hsd_table → HDF5)
46 : ! ===========================================================================
47 :
48 : !> Dump an hsd_table tree to an HDF5 file.
49 13 : subroutine hdf5_backend_dump(root, filename, error, pretty)
50 : type(hsd_table), intent(in) :: root
51 : character(len=*), intent(in) :: filename
52 : type(hsd_error_t), allocatable, intent(out), optional :: error
53 : logical, intent(in), optional :: pretty
54 :
55 13 : integer(hid_t) :: file_id
56 13 : integer :: hdferr
57 13 : type(hsd_table) :: root_copy
58 :
59 : ! pretty is accepted for interface compatibility
60 : if (.false. .and. present(pretty)) continue
61 :
62 : ! Clone the tree because array getters need intent(inout)
63 13 : call hsd_clone(root, root_copy)
64 :
65 13 : call h5open_f(hdferr)
66 13 : if (hdferr /= 0) then
67 0 : call set_error_(error, "Failed to initialise HDF5 library")
68 0 : return
69 : end if
70 :
71 13 : call h5fcreate_f(filename, h5f_acc_trunc_f, file_id, hdferr)
72 13 : if (hdferr /= 0) then
73 0 : call set_error_(error, "Failed to create HDF5 file: " // trim(filename))
74 0 : call h5close_f(hdferr)
75 0 : return
76 : end if
77 :
78 : ! Write the tree into the root group of the file
79 13 : call write_table_(root_copy, file_id, error)
80 :
81 13 : call h5fclose_f(file_id, hdferr)
82 13 : call h5close_f(hdferr)
83 :
84 247 : end subroutine hdf5_backend_dump
85 :
86 : ! ---------------------------------------------------------------------------
87 : ! Write helpers
88 : ! ---------------------------------------------------------------------------
89 :
90 : !> Write all children of an hsd_table into the given HDF5 group.
91 21 : recursive subroutine write_table_(table, group_id, error)
92 : type(hsd_table), intent(inout) :: table
93 : integer(hid_t), intent(in) :: group_id
94 : type(hsd_error_t), allocatable, intent(out), optional :: error
95 :
96 21 : integer :: ii
97 :
98 : ! Write attrib of the table itself, if present
99 21 : if (allocated(table%attrib)) then
100 2 : if (len(table%attrib) > 0) then
101 1 : call write_string_attr_(group_id, "attrib", table%attrib)
102 : end if
103 : end if
104 :
105 52 : do ii = 1, table%num_children
106 31 : if (.not. associated(table%children(ii)%node)) cycle
107 0 : select type (child => table%children(ii)%node)
108 : type is (hsd_table)
109 8 : call write_child_table_(child, group_id, error)
110 16 : if (present(error)) then
111 8 : if (allocated(error)) return
112 : end if
113 : type is (hsd_value)
114 23 : call write_child_value_(child, group_id, error)
115 46 : if (present(error)) then
116 23 : if (allocated(error)) return
117 : end if
118 : end select
119 : end do
120 :
121 13 : end subroutine write_table_
122 :
123 : !> Write a child hsd_table as an HDF5 group.
124 8 : recursive subroutine write_child_table_(child, parent_id, error)
125 : type(hsd_table), intent(inout) :: child
126 : integer(hid_t), intent(in) :: parent_id
127 : type(hsd_error_t), allocatable, intent(out), optional :: error
128 :
129 8 : integer(hid_t) :: grp_id
130 8 : integer :: hdferr
131 8 : character(len=:), allocatable :: grp_name
132 :
133 8 : grp_name = safe_name_(child%name)
134 8 : call h5gcreate_f(parent_id, grp_name, grp_id, hdferr)
135 8 : if (hdferr /= 0) then
136 0 : call set_error_(error, "Failed to create HDF5 group: " // grp_name)
137 0 : return
138 : end if
139 :
140 8 : call write_table_(child, grp_id, error)
141 :
142 8 : call h5gclose_f(grp_id, hdferr)
143 :
144 8 : end subroutine write_child_table_
145 :
146 : !> Write a child hsd_value as an HDF5 dataset.
147 23 : subroutine write_child_value_(val, parent_id, error)
148 : type(hsd_value), intent(inout) :: val
149 : integer(hid_t), intent(in) :: parent_id
150 : type(hsd_error_t), allocatable, intent(out), optional :: error
151 :
152 23 : character(len=:), allocatable :: ds_name
153 23 : integer(hid_t) :: ds_id
154 23 : integer :: hdferr
155 :
156 23 : ds_name = safe_name_(val%name)
157 23 : ds_id = -1
158 :
159 29 : select case (val%value_type)
160 : case (VALUE_TYPE_STRING)
161 12 : call write_string_ds_(parent_id, ds_name, val%string_value, ds_id)
162 : case (VALUE_TYPE_INTEGER)
163 8 : call write_int_scalar_ds_(parent_id, ds_name, val%int_value, ds_id)
164 : case (VALUE_TYPE_REAL)
165 6 : call write_real_scalar_ds_(parent_id, ds_name, val%real_value, ds_id)
166 : case (VALUE_TYPE_LOGICAL)
167 6 : call write_logical_scalar_ds_(parent_id, ds_name, val%logical_value, ds_id)
168 : case (VALUE_TYPE_COMPLEX)
169 2 : call write_complex_scalar_ds_(parent_id, ds_name, val%complex_value, ds_id)
170 : case (VALUE_TYPE_ARRAY)
171 12 : call write_array_ds_(val, parent_id, ds_name, ds_id, error)
172 : case (VALUE_TYPE_NONE)
173 : ! Write empty string dataset for VALUE_TYPE_NONE
174 0 : call write_string_ds_(parent_id, ds_name, "", ds_id)
175 : case default
176 : ! Unknown type — write empty string as fallback
177 46 : call write_string_ds_(parent_id, ds_name, "", ds_id)
178 : end select
179 :
180 : ! Write attrib as HDF5 attribute on the dataset
181 23 : if (ds_id >= 0 .and. allocated(val%attrib)) then
182 4 : if (len(val%attrib) > 0) then
183 2 : call write_string_attr_on_ds_(ds_id, "attrib", val%attrib)
184 : end if
185 : end if
186 23 : if (ds_id >= 0) then
187 23 : call h5dclose_f(ds_id, hdferr)
188 : end if
189 :
190 23 : end subroutine write_child_value_
191 :
192 : !> Write a scalar integer dataset.
193 7 : subroutine write_int_scalar_ds_(parent_id, name, val, ds_id)
194 : integer(hid_t), intent(in) :: parent_id
195 : character(len=*), intent(in) :: name
196 : integer, intent(in) :: val
197 : integer(hid_t), intent(out) :: ds_id
198 :
199 7 : integer(hid_t) :: space_id
200 7 : integer :: hdferr
201 7 : integer, target :: buf
202 :
203 7 : buf = val
204 7 : call h5screate_f(h5s_scalar_f, space_id, hdferr)
205 7 : call h5dcreate_f(parent_id, name, h5t_native_integer, space_id, ds_id, hdferr)
206 7 : call h5dwrite_f(ds_id, h5t_native_integer, buf, [int(1, hsize_t)], hdferr)
207 7 : call h5sclose_f(space_id, hdferr)
208 :
209 23 : end subroutine write_int_scalar_ds_
210 :
211 : !> Write a scalar double-precision real dataset.
212 3 : subroutine write_real_scalar_ds_(parent_id, name, val, ds_id)
213 : integer(hid_t), intent(in) :: parent_id
214 : character(len=*), intent(in) :: name
215 : real(dp), intent(in) :: val
216 : integer(hid_t), intent(out) :: ds_id
217 :
218 3 : integer(hid_t) :: space_id
219 3 : integer :: hdferr
220 3 : real(dp), target :: buf
221 :
222 3 : buf = val
223 3 : call h5screate_f(h5s_scalar_f, space_id, hdferr)
224 3 : call h5dcreate_f(parent_id, name, h5t_native_double, space_id, ds_id, hdferr)
225 3 : call h5dwrite_f(ds_id, h5t_native_double, buf, [int(1, hsize_t)], hdferr)
226 3 : call h5sclose_f(space_id, hdferr)
227 :
228 7 : end subroutine write_real_scalar_ds_
229 :
230 : !> Write a scalar logical as integer 0/1 dataset.
231 3 : subroutine write_logical_scalar_ds_(parent_id, name, val, ds_id)
232 : integer(hid_t), intent(in) :: parent_id
233 : character(len=*), intent(in) :: name
234 : logical, intent(in) :: val
235 : integer(hid_t), intent(out) :: ds_id
236 :
237 3 : integer :: ival
238 :
239 3 : if (val) then
240 2 : ival = 1
241 : else
242 1 : ival = 0
243 : end if
244 3 : call write_int_scalar_ds_(parent_id, name, ival, ds_id)
245 : ! Mark it as a logical with a type attribute
246 3 : call write_string_attr_on_ds_(ds_id, "hsd_type", "logical")
247 :
248 3 : end subroutine write_logical_scalar_ds_
249 :
250 : !> Write a scalar complex as compound {re, im} dataset.
251 1 : subroutine write_complex_scalar_ds_(parent_id, name, val, ds_id)
252 : integer(hid_t), intent(in) :: parent_id
253 : character(len=*), intent(in) :: name
254 : complex(dp), intent(in) :: val
255 : integer(hid_t), intent(out) :: ds_id
256 :
257 1 : integer(hid_t) :: space_id, ctype_id
258 1 : integer :: hdferr
259 1 : integer(size_t) :: type_size, offset
260 3 : real(dp), target :: buf(2)
261 :
262 1 : buf(1) = real(val, dp)
263 1 : buf(2) = aimag(val)
264 :
265 : ! Create compound type with re and im fields
266 1 : type_size = int(2 * storage_size(1.0_dp) / 8, size_t)
267 1 : call h5tcreate_f(h5t_compound_f, type_size, ctype_id, hdferr)
268 :
269 1 : offset = int(0, size_t)
270 1 : call h5tinsert_f(ctype_id, "re", offset, h5t_native_double, hdferr)
271 1 : offset = int(storage_size(1.0_dp) / 8, size_t)
272 1 : call h5tinsert_f(ctype_id, "im", offset, h5t_native_double, hdferr)
273 :
274 1 : call h5screate_f(h5s_scalar_f, space_id, hdferr)
275 1 : call h5dcreate_f(parent_id, name, ctype_id, space_id, ds_id, hdferr)
276 1 : call h5dwrite_f(ds_id, ctype_id, buf, [int(1, hsize_t)], hdferr)
277 1 : call h5sclose_f(space_id, hdferr)
278 1 : call h5tclose_f(ctype_id, hdferr)
279 :
280 3 : end subroutine write_complex_scalar_ds_
281 :
282 : !> Write a variable-length string dataset.
283 7 : subroutine write_string_ds_(parent_id, name, val, ds_id)
284 : integer(hid_t), intent(in) :: parent_id
285 : character(len=*), intent(in) :: name
286 : character(len=*), intent(in) :: val
287 : integer(hid_t), intent(out) :: ds_id
288 :
289 7 : integer(hid_t) :: space_id, type_id
290 7 : integer :: hdferr
291 14 : integer(hsize_t) :: dims(1)
292 :
293 7 : dims = [int(1, hsize_t)]
294 :
295 : ! Create fixed-length string type matching the value length
296 7 : call h5tcopy_f(h5t_fortran_s1, type_id, hdferr)
297 7 : if (len(val) > 0) then
298 7 : call h5tset_size_f(type_id, int(len(val), size_t), hdferr)
299 : else
300 0 : call h5tset_size_f(type_id, int(1, size_t), hdferr)
301 : end if
302 :
303 7 : call h5screate_f(h5s_scalar_f, space_id, hdferr)
304 7 : call h5dcreate_f(parent_id, name, type_id, space_id, ds_id, hdferr)
305 7 : if (len(val) > 0) then
306 7 : call h5dwrite_f(ds_id, type_id, val, dims, hdferr)
307 : else
308 0 : call h5dwrite_f(ds_id, type_id, " ", dims, hdferr)
309 : end if
310 7 : call h5sclose_f(space_id, hdferr)
311 7 : call h5tclose_f(type_id, hdferr)
312 :
313 : ! Mark as string type
314 7 : call write_string_attr_on_ds_(ds_id, "hsd_type", "string")
315 :
316 22 : end subroutine write_string_ds_
317 :
318 : !> Write array/matrix data from an hsd_value to an HDF5 dataset.
319 6 : subroutine write_array_ds_(val, parent_id, name, ds_id, error)
320 : type(hsd_value), intent(inout) :: val
321 : integer(hid_t), intent(in) :: parent_id
322 : character(len=*), intent(in) :: name
323 : integer(hid_t), intent(out) :: ds_id
324 : type(hsd_error_t), allocatable, intent(out), optional :: error
325 :
326 6 : integer :: stat
327 6 : integer, allocatable :: imat(:,:)
328 6 : real(dp), allocatable :: rmat(:,:)
329 6 : integer :: nrows, ncols
330 :
331 : ! Try matrix (2-D) first — check if raw_text contains newlines
332 6 : if (allocated(val%raw_text)) then
333 6 : if (index(val%raw_text, new_line("a")) > 0) then
334 : ! Try integer matrix
335 3 : call val%get_int_matrix(imat, nrows, ncols, stat)
336 3 : if (stat == 0 .and. nrows > 0 .and. ncols > 0) then
337 1 : call write_int_matrix_ds_(parent_id, name, imat, nrows, ncols, ds_id)
338 1 : return
339 : end if
340 : ! Try real matrix
341 2 : call val%get_real_matrix(rmat, nrows, ncols, stat)
342 2 : if (stat == 0 .and. nrows > 0 .and. ncols > 0) then
343 2 : call write_real_matrix_ds_(parent_id, name, rmat, nrows, ncols, ds_id)
344 2 : return
345 : end if
346 : end if
347 : end if
348 :
349 : ! Try 1-D arrays
350 3 : call try_write_1d_array_(val, parent_id, name, ds_id, error)
351 :
352 13 : end subroutine write_array_ds_
353 :
354 : !> Try to write a 1-D array dataset, detecting element type.
355 3 : subroutine try_write_1d_array_(val, parent_id, name, ds_id, error)
356 : type(hsd_value), intent(inout) :: val
357 : integer(hid_t), intent(in) :: parent_id
358 : character(len=*), intent(in) :: name
359 : integer(hid_t), intent(out) :: ds_id
360 : type(hsd_error_t), allocatable, intent(out), optional :: error
361 :
362 3 : integer :: stat
363 3 : integer, allocatable :: iarr(:)
364 3 : real(dp), allocatable :: rarr(:)
365 3 : complex(dp), allocatable :: carr(:)
366 :
367 : ! Try integer array
368 3 : call val%get_int_array(iarr, stat)
369 3 : if (stat == 0 .and. allocated(iarr)) then
370 1 : call write_int_1d_ds_(parent_id, name, iarr, ds_id)
371 1 : return
372 : end if
373 :
374 : ! Try real array
375 2 : call val%get_real_array(rarr, stat)
376 2 : if (stat == 0 .and. allocated(rarr)) then
377 1 : call write_real_1d_ds_(parent_id, name, rarr, ds_id)
378 1 : return
379 : end if
380 :
381 : ! Try complex array
382 1 : call val%get_complex_array(carr, stat)
383 1 : if (stat == 0 .and. allocated(carr)) then
384 0 : call write_complex_1d_ds_(parent_id, name, carr, ds_id)
385 0 : return
386 : end if
387 :
388 : ! Fall back: write raw_text as string
389 1 : if (allocated(val%raw_text)) then
390 1 : call write_string_ds_(parent_id, name, val%raw_text, ds_id)
391 : else
392 0 : call write_string_ds_(parent_id, name, "", ds_id)
393 : end if
394 :
395 9 : end subroutine try_write_1d_array_
396 :
397 : !> Write a 1-D integer array dataset.
398 2 : subroutine write_int_1d_ds_(parent_id, name, arr, ds_id)
399 : integer(hid_t), intent(in) :: parent_id
400 : character(len=*), intent(in) :: name
401 : integer, intent(in) :: arr(:)
402 : integer(hid_t), intent(out) :: ds_id
403 :
404 1 : integer(hid_t) :: space_id
405 1 : integer :: hdferr
406 2 : integer(hsize_t) :: dims(1)
407 :
408 1 : dims(1) = int(size(arr), hsize_t)
409 1 : call h5screate_simple_f(1, dims, space_id, hdferr)
410 1 : call h5dcreate_f(parent_id, name, h5t_native_integer, space_id, ds_id, hdferr)
411 1 : call h5dwrite_f(ds_id, h5t_native_integer, arr, dims, hdferr)
412 1 : call h5sclose_f(space_id, hdferr)
413 :
414 3 : end subroutine write_int_1d_ds_
415 :
416 : !> Write a 1-D real(dp) array dataset.
417 2 : subroutine write_real_1d_ds_(parent_id, name, arr, ds_id)
418 : integer(hid_t), intent(in) :: parent_id
419 : character(len=*), intent(in) :: name
420 : real(dp), intent(in) :: arr(:)
421 : integer(hid_t), intent(out) :: ds_id
422 :
423 1 : integer(hid_t) :: space_id
424 1 : integer :: hdferr
425 2 : integer(hsize_t) :: dims(1)
426 :
427 1 : dims(1) = int(size(arr), hsize_t)
428 1 : call h5screate_simple_f(1, dims, space_id, hdferr)
429 1 : call h5dcreate_f(parent_id, name, h5t_native_double, space_id, ds_id, hdferr)
430 1 : call h5dwrite_f(ds_id, h5t_native_double, arr, dims, hdferr)
431 1 : call h5sclose_f(space_id, hdferr)
432 :
433 1 : end subroutine write_real_1d_ds_
434 :
435 : !> Write a 1-D complex(dp) array as a compound dataset.
436 0 : subroutine write_complex_1d_ds_(parent_id, name, arr, ds_id)
437 : integer(hid_t), intent(in) :: parent_id
438 : character(len=*), intent(in) :: name
439 : complex(dp), intent(in) :: arr(:)
440 : integer(hid_t), intent(out) :: ds_id
441 :
442 0 : integer(hid_t) :: space_id, ctype_id
443 0 : integer :: hdferr, ii
444 0 : integer(hsize_t) :: dims(1)
445 0 : integer(size_t) :: type_size, offset
446 0 : real(dp), allocatable :: buf(:,:)
447 :
448 0 : dims(1) = int(size(arr), hsize_t)
449 0 : allocate(buf(2, size(arr)))
450 0 : do ii = 1, size(arr)
451 0 : buf(1, ii) = real(arr(ii), dp)
452 0 : buf(2, ii) = aimag(arr(ii))
453 : end do
454 :
455 0 : type_size = int(2 * storage_size(1.0_dp) / 8, size_t)
456 0 : call h5tcreate_f(h5t_compound_f, type_size, ctype_id, hdferr)
457 0 : offset = int(0, size_t)
458 0 : call h5tinsert_f(ctype_id, "re", offset, h5t_native_double, hdferr)
459 0 : offset = int(storage_size(1.0_dp) / 8, size_t)
460 0 : call h5tinsert_f(ctype_id, "im", offset, h5t_native_double, hdferr)
461 :
462 0 : call h5screate_simple_f(1, dims, space_id, hdferr)
463 0 : call h5dcreate_f(parent_id, name, ctype_id, space_id, ds_id, hdferr)
464 0 : call h5dwrite_f(ds_id, ctype_id, buf, dims, hdferr)
465 0 : call h5sclose_f(space_id, hdferr)
466 0 : call h5tclose_f(ctype_id, hdferr)
467 :
468 1 : end subroutine write_complex_1d_ds_
469 :
470 : !> Write a 2-D integer matrix dataset.
471 2 : subroutine write_int_matrix_ds_(parent_id, name, mat, nrows, ncols, ds_id)
472 : integer(hid_t), intent(in) :: parent_id
473 : character(len=*), intent(in) :: name
474 : integer, intent(in) :: mat(:,:)
475 : integer, intent(in) :: nrows, ncols
476 : integer(hid_t), intent(out) :: ds_id
477 :
478 1 : integer(hid_t) :: space_id
479 1 : integer :: hdferr
480 3 : integer(hsize_t) :: dims(2)
481 :
482 : ! HDF5 uses C order (row-major), Fortran is column-major
483 : ! Store as (ncols, nrows) in HDF5 so readers see (nrows, ncols)
484 1 : dims(1) = int(ncols, hsize_t)
485 1 : dims(2) = int(nrows, hsize_t)
486 1 : call h5screate_simple_f(2, dims, space_id, hdferr)
487 1 : call h5dcreate_f(parent_id, name, h5t_native_integer, space_id, ds_id, hdferr)
488 1 : call h5dwrite_f(ds_id, h5t_native_integer, mat, dims, hdferr)
489 1 : call h5sclose_f(space_id, hdferr)
490 :
491 0 : end subroutine write_int_matrix_ds_
492 :
493 : !> Write a 2-D real(dp) matrix dataset.
494 4 : subroutine write_real_matrix_ds_(parent_id, name, mat, nrows, ncols, ds_id)
495 : integer(hid_t), intent(in) :: parent_id
496 : character(len=*), intent(in) :: name
497 : real(dp), intent(in) :: mat(:,:)
498 : integer, intent(in) :: nrows, ncols
499 : integer(hid_t), intent(out) :: ds_id
500 :
501 2 : integer(hid_t) :: space_id
502 2 : integer :: hdferr
503 6 : integer(hsize_t) :: dims(2)
504 :
505 2 : dims(1) = int(ncols, hsize_t)
506 2 : dims(2) = int(nrows, hsize_t)
507 2 : call h5screate_simple_f(2, dims, space_id, hdferr)
508 2 : call h5dcreate_f(parent_id, name, h5t_native_double, space_id, ds_id, hdferr)
509 2 : call h5dwrite_f(ds_id, h5t_native_double, mat, dims, hdferr)
510 2 : call h5sclose_f(space_id, hdferr)
511 :
512 1 : end subroutine write_real_matrix_ds_
513 :
514 : ! ---------------------------------------------------------------------------
515 : ! Reader (HDF5 → hsd_table)
516 : ! ---------------------------------------------------------------------------
517 :
518 : !> Load an HDF5 file into an hsd_table tree.
519 26 : subroutine hdf5_backend_load(filename, root, error)
520 : character(len=*), intent(in) :: filename
521 : type(hsd_table), intent(out) :: root
522 : type(hsd_error_t), allocatable, intent(out), optional :: error
523 :
524 13 : integer(hid_t) :: file_id
525 13 : integer :: hdferr
526 :
527 13 : call h5open_f(hdferr)
528 13 : if (hdferr /= 0) then
529 0 : call set_error_(error, "Failed to initialise HDF5 library")
530 0 : return
531 : end if
532 :
533 13 : call h5fopen_f(filename, h5f_acc_rdonly_f, file_id, hdferr)
534 13 : if (hdferr /= 0) then
535 0 : call set_error_(error, "Failed to open HDF5 file: " // trim(filename))
536 0 : call h5close_f(hdferr)
537 0 : return
538 : end if
539 :
540 13 : call new_table(root)
541 13 : call read_group_(file_id, root, error)
542 :
543 13 : call h5fclose_f(file_id, hdferr)
544 13 : call h5close_f(hdferr)
545 :
546 15 : end subroutine hdf5_backend_load
547 :
548 : ! ---------------------------------------------------------------------------
549 : ! Read helpers
550 : ! ---------------------------------------------------------------------------
551 :
552 : !> Read all objects in an HDF5 group into an hsd_table.
553 42 : recursive subroutine read_group_(group_id, table, error)
554 : integer(hid_t), intent(in) :: group_id
555 : type(hsd_table), intent(inout) :: table
556 : type(hsd_error_t), allocatable, intent(out), optional :: error
557 :
558 21 : integer :: hdferr, nmembers, ii, obj_type
559 21 : integer(size_t) :: name_len
560 : character(len=256) :: member_name
561 :
562 : ! Read group-level attrib if present
563 21 : call read_attrib_if_exists_(group_id, table)
564 :
565 21 : call h5gn_members_f(group_id, ".", nmembers, hdferr)
566 21 : if (hdferr /= 0) return
567 :
568 52 : do ii = 0, nmembers - 1
569 31 : call h5gget_obj_info_idx_f(group_id, ".", ii, member_name, obj_type, hdferr)
570 31 : if (hdferr /= 0) cycle
571 31 : name_len = int(index(member_name, char(0)) - 1, size_t)
572 31 : if (name_len <= 0) name_len = int(len_trim(member_name), size_t)
573 :
574 91 : if (obj_type == h5g_group_f) then
575 8 : call read_child_group_(group_id, member_name(:name_len), table, error)
576 8 : if (present(error)) then
577 8 : if (allocated(error)) return
578 : end if
579 46 : else if (obj_type == h5g_dataset_f) then
580 23 : call read_child_dataset_(group_id, member_name(:name_len), table, error)
581 23 : if (present(error)) then
582 23 : if (allocated(error)) return
583 : end if
584 : end if
585 : end do
586 :
587 13 : end subroutine read_group_
588 :
589 : !> Read a child group into the parent table.
590 8 : recursive subroutine read_child_group_(parent_id, name, parent_table, error)
591 : integer(hid_t), intent(in) :: parent_id
592 : character(len=*), intent(in) :: name
593 : type(hsd_table), intent(inout) :: parent_table
594 : type(hsd_error_t), allocatable, intent(out), optional :: error
595 :
596 8 : integer(hid_t) :: grp_id
597 8 : integer :: hdferr
598 8 : type(hsd_table) :: child_table
599 :
600 8 : call h5gopen_f(parent_id, name, grp_id, hdferr)
601 8 : if (hdferr /= 0) then
602 0 : call set_error_(error, "Failed to open HDF5 group: " // name)
603 0 : return
604 : end if
605 :
606 8 : call new_table(child_table, name=name)
607 8 : call read_group_(grp_id, child_table, error)
608 8 : call parent_table%add_child(child_table)
609 :
610 8 : call h5gclose_f(grp_id, hdferr)
611 :
612 160 : end subroutine read_child_group_
613 :
614 : !> Read a dataset and add it as an hsd_value to the parent table.
615 23 : subroutine read_child_dataset_(parent_id, name, parent_table, error)
616 : integer(hid_t), intent(in) :: parent_id
617 : character(len=*), intent(in) :: name
618 : type(hsd_table), intent(inout) :: parent_table
619 : type(hsd_error_t), allocatable, intent(out), optional :: error
620 :
621 46 : integer(hid_t) :: ds_id, space_id, type_id
622 46 : integer :: hdferr, ndims, type_class
623 115 : integer(hsize_t) :: dims(2), maxdims(2)
624 23 : integer(size_t) :: type_size
625 23 : type(hsd_value) :: val
626 :
627 23 : call h5dopen_f(parent_id, name, ds_id, hdferr)
628 23 : if (hdferr /= 0) then
629 0 : call set_error_(error, "Failed to open HDF5 dataset: " // name)
630 0 : return
631 : end if
632 :
633 23 : call h5dget_space_f(ds_id, space_id, hdferr)
634 23 : call h5sget_simple_extent_ndims_f(space_id, ndims, hdferr)
635 :
636 23 : dims = 0
637 23 : if (ndims > 0) then
638 5 : call h5sget_simple_extent_dims_f(space_id, dims, maxdims, hdferr)
639 : end if
640 :
641 23 : call h5dget_type_f(ds_id, type_id, hdferr)
642 23 : call h5tget_class_f(type_id, type_class, hdferr)
643 23 : call h5tget_size_f(type_id, type_size, hdferr)
644 :
645 23 : call new_value(val, name=name)
646 :
647 23 : if (type_class == h5t_integer_f) then
648 9 : call read_integer_ds_(ds_id, ndims, dims, val)
649 14 : else if (type_class == h5t_float_f) then
650 6 : call read_float_ds_(ds_id, ndims, dims, val)
651 8 : else if (type_class == h5t_string_f) then
652 7 : call read_string_ds_(ds_id, type_id, type_size, val)
653 1 : else if (type_class == h5t_compound_f) then
654 1 : call read_compound_ds_(ds_id, type_id, ndims, dims, val)
655 : end if
656 :
657 : ! Read dataset attributes (attrib, hsd_type)
658 23 : call read_ds_attrs_(ds_id, val)
659 23 : call parent_table%add_child(val)
660 :
661 23 : call h5tclose_f(type_id, hdferr)
662 23 : call h5sclose_f(space_id, hdferr)
663 23 : call h5dclose_f(ds_id, hdferr)
664 :
665 23 : end subroutine read_child_dataset_
666 :
667 : !> Read an integer dataset (scalar, 1-D, or 2-D).
668 9 : subroutine read_integer_ds_(ds_id, ndims, dims, val)
669 : integer(hid_t), intent(in) :: ds_id
670 : integer, intent(in) :: ndims
671 : integer(hsize_t), intent(in) :: dims(2)
672 : type(hsd_value), intent(inout) :: val
673 :
674 9 : integer :: hdferr
675 9 : integer, target :: scalar_buf
676 9 : integer, allocatable :: arr(:), mat(:,:)
677 9 : character(len=:), allocatable :: raw
678 :
679 9 : if (ndims == 0) then
680 : ! Scalar
681 : call h5dread_f(ds_id, h5t_native_integer, scalar_buf, &
682 7 : & [int(1, hsize_t)], hdferr)
683 7 : call val%set_integer(scalar_buf)
684 2 : else if (ndims == 1) then
685 : ! 1-D array
686 1 : allocate(arr(dims(1)))
687 1 : call h5dread_f(ds_id, h5t_native_integer, arr, dims(1:1), hdferr)
688 1 : raw = int_array_to_string_(arr)
689 1 : call val%set_raw(raw)
690 : else
691 : ! 2-D matrix — dims in HDF5 are (ncols, nrows) due to C/Fortran order
692 1 : allocate(mat(dims(1), dims(2)))
693 1 : call h5dread_f(ds_id, h5t_native_integer, mat, dims(1:2), hdferr)
694 1 : raw = int_matrix_to_string_(mat, int(dims(2)), int(dims(1)))
695 2 : call val%set_raw(raw)
696 : end if
697 :
698 32 : end subroutine read_integer_ds_
699 :
700 : !> Read a float dataset (scalar, 1-D, or 2-D).
701 6 : subroutine read_float_ds_(ds_id, ndims, dims, val)
702 : integer(hid_t), intent(in) :: ds_id
703 : integer, intent(in) :: ndims
704 : integer(hsize_t), intent(in) :: dims(2)
705 : type(hsd_value), intent(inout) :: val
706 :
707 6 : integer :: hdferr
708 6 : real(dp), target :: scalar_buf
709 6 : real(dp), allocatable :: arr(:), mat(:,:)
710 6 : character(len=:), allocatable :: raw
711 :
712 6 : if (ndims == 0) then
713 : call h5dread_f(ds_id, h5t_native_double, scalar_buf, &
714 3 : & [int(1, hsize_t)], hdferr)
715 3 : call val%set_real(scalar_buf)
716 3 : else if (ndims == 1) then
717 1 : allocate(arr(dims(1)))
718 1 : call h5dread_f(ds_id, h5t_native_double, arr, dims(1:1), hdferr)
719 1 : raw = real_array_to_string_(arr)
720 1 : call val%set_raw(raw)
721 : else
722 2 : allocate(mat(dims(1), dims(2)))
723 2 : call h5dread_f(ds_id, h5t_native_double, mat, dims(1:2), hdferr)
724 2 : raw = real_matrix_to_string_(mat, int(dims(2)), int(dims(1)))
725 4 : call val%set_raw(raw)
726 : end if
727 :
728 15 : end subroutine read_float_ds_
729 :
730 : !> Read a string dataset.
731 7 : subroutine read_string_ds_(ds_id, type_id, type_size, val)
732 : integer(hid_t), intent(in) :: ds_id, type_id
733 : integer(size_t), intent(in) :: type_size
734 : type(hsd_value), intent(inout) :: val
735 :
736 7 : integer :: hdferr
737 7 : character(len=:), allocatable :: buf
738 :
739 7 : allocate(character(len=int(type_size)) :: buf)
740 7 : call h5dread_f(ds_id, type_id, buf, [int(1, hsize_t)], hdferr)
741 :
742 : ! Trim trailing nulls/spaces
743 7 : buf = trim(adjustl(buf))
744 7 : call val%set_string(buf)
745 :
746 13 : end subroutine read_string_ds_
747 :
748 : !> Read a compound dataset (assumed to be complex {re, im}).
749 1 : subroutine read_compound_ds_(ds_id, type_id, ndims, dims, val)
750 : integer(hid_t), intent(in) :: ds_id, type_id
751 : integer, intent(in) :: ndims
752 : integer(hsize_t), intent(in) :: dims(2)
753 : type(hsd_value), intent(inout) :: val
754 :
755 1 : integer :: hdferr, nmembers
756 3 : real(dp), target :: scalar_buf(2)
757 1 : real(dp), allocatable :: arr_buf(:,:)
758 1 : character(len=:), allocatable :: raw
759 :
760 : ! Verify it's a 2-member compound (re, im)
761 1 : call h5tget_nmembers_f(type_id, nmembers, hdferr)
762 1 : if (nmembers /= 2) return ! not a complex type
763 :
764 1 : if (ndims == 0) then
765 : ! Scalar complex
766 1 : call h5dread_f(ds_id, type_id, scalar_buf, [int(1, hsize_t)], hdferr)
767 1 : call val%set_complex(cmplx(scalar_buf(1), scalar_buf(2), dp))
768 0 : else if (ndims == 1) then
769 : ! 1-D complex array
770 0 : allocate(arr_buf(2, dims(1)))
771 0 : call h5dread_f(ds_id, type_id, arr_buf, dims(1:1), hdferr)
772 0 : raw = complex_array_to_string_(arr_buf, int(dims(1)))
773 0 : call val%set_raw(raw)
774 : end if
775 :
776 8 : end subroutine read_compound_ds_
777 :
778 : !> Read dataset-level HDF5 attributes into hsd_value attrib/type.
779 23 : subroutine read_ds_attrs_(ds_id, val)
780 : integer(hid_t), intent(in) :: ds_id
781 : type(hsd_value), intent(inout) :: val
782 :
783 : character(len=256) :: attr_val
784 23 : logical :: attr_exists
785 23 : integer :: hdferr
786 :
787 : ! Read "attrib" → hsd_value%attrib
788 23 : call h5aexists_f(ds_id, "attrib", attr_exists, hdferr)
789 23 : if (attr_exists) then
790 2 : call read_string_attribute_(ds_id, "attrib", attr_val, hdferr)
791 2 : if (hdferr == 0) val%attrib = trim(attr_val)
792 : end if
793 :
794 : ! Read "hsd_type" to restore logical type
795 23 : call h5aexists_f(ds_id, "hsd_type", attr_exists, hdferr)
796 23 : if (attr_exists) then
797 10 : call read_string_attribute_(ds_id, "hsd_type", attr_val, hdferr)
798 10 : if (hdferr == 0) then
799 10 : if (trim(attr_val) == "logical") then
800 : ! Convert integer 0/1 back to logical
801 3 : if (val%value_type == VALUE_TYPE_INTEGER) then
802 3 : call val%set_logical(val%int_value /= 0)
803 : end if
804 : end if
805 : end if
806 : end if
807 :
808 1 : end subroutine read_ds_attrs_
809 :
810 : !> Read attrib from a group into an hsd_table.
811 21 : subroutine read_attrib_if_exists_(obj_id, table)
812 : integer(hid_t), intent(in) :: obj_id
813 : type(hsd_table), intent(inout) :: table
814 :
815 : character(len=256) :: attr_val
816 21 : logical :: attr_exists
817 21 : integer :: hdferr
818 :
819 21 : call h5aexists_f(obj_id, "attrib", attr_exists, hdferr)
820 21 : if (attr_exists) then
821 1 : call read_string_attribute_(obj_id, "attrib", attr_val, hdferr)
822 1 : if (hdferr == 0) table%attrib = trim(attr_val)
823 : end if
824 :
825 23 : end subroutine read_attrib_if_exists_
826 :
827 : !> Read a string attribute from an HDF5 object.
828 13 : subroutine read_string_attribute_(obj_id, attr_name, attr_val, hdferr)
829 : integer(hid_t), intent(in) :: obj_id
830 : character(len=*), intent(in) :: attr_name
831 : character(len=256), intent(out) :: attr_val
832 : integer, intent(out) :: hdferr
833 :
834 13 : integer(hid_t) :: attr_id, atype_id
835 26 : integer(hsize_t) :: dims(1)
836 :
837 13 : dims = [int(1, hsize_t)]
838 13 : attr_val = ""
839 :
840 13 : call h5aopen_f(obj_id, attr_name, attr_id, hdferr)
841 13 : if (hdferr /= 0) return
842 :
843 13 : call h5aget_type_f(attr_id, atype_id, hdferr)
844 13 : call h5aread_f(attr_id, atype_id, attr_val, dims, hdferr)
845 13 : call h5tclose_f(atype_id, hdferr)
846 13 : call h5aclose_f(attr_id, hdferr)
847 :
848 47 : end subroutine read_string_attribute_
849 :
850 : ! ---------------------------------------------------------------------------
851 : ! Attribute writers
852 : ! ---------------------------------------------------------------------------
853 :
854 : !> Write a string attribute on a group (for table attrib).
855 13 : subroutine write_string_attr_(group_id, attr_name, attr_val)
856 : integer(hid_t), intent(in) :: group_id
857 : character(len=*), intent(in) :: attr_name
858 : character(len=*), intent(in) :: attr_val
859 :
860 26 : integer(hid_t) :: space_id, atype_id, attr_id
861 13 : integer :: hdferr
862 26 : integer(hsize_t) :: dims(1)
863 :
864 13 : dims = [int(1, hsize_t)]
865 13 : call h5screate_f(h5s_scalar_f, space_id, hdferr)
866 13 : call h5tcopy_f(h5t_fortran_s1, atype_id, hdferr)
867 13 : call h5tset_size_f(atype_id, int(len(attr_val), size_t), hdferr)
868 13 : call h5acreate_f(group_id, attr_name, atype_id, space_id, attr_id, hdferr)
869 13 : call h5awrite_f(attr_id, atype_id, attr_val, dims, hdferr)
870 13 : call h5aclose_f(attr_id, hdferr)
871 13 : call h5tclose_f(atype_id, hdferr)
872 13 : call h5sclose_f(space_id, hdferr)
873 :
874 39 : end subroutine write_string_attr_
875 :
876 : !> Write a string attribute on a dataset (for value attrib).
877 12 : subroutine write_string_attr_on_ds_(ds_id, attr_name, attr_val)
878 : integer(hid_t), intent(in) :: ds_id
879 : character(len=*), intent(in) :: attr_name
880 : character(len=*), intent(in) :: attr_val
881 :
882 12 : call write_string_attr_(ds_id, attr_name, attr_val)
883 :
884 13 : end subroutine write_string_attr_on_ds_
885 :
886 : ! ---------------------------------------------------------------------------
887 : ! Formatting helpers (array/matrix → raw_text string)
888 : ! ---------------------------------------------------------------------------
889 :
890 : !> Convert an integer array to space-separated string.
891 2 : function int_array_to_string_(arr) result(str)
892 : integer, intent(in) :: arr(:)
893 : character(len=:), allocatable :: str
894 :
895 : character(len=32) :: buf
896 1 : integer :: ii
897 :
898 1 : str = ""
899 6 : do ii = 1, size(arr)
900 5 : write(buf, "(i0)") arr(ii)
901 9 : if (ii > 1) str = str // " "
902 6 : str = str // trim(buf)
903 : end do
904 :
905 12 : end function int_array_to_string_
906 :
907 : !> Convert a real(dp) array to space-separated string.
908 2 : function real_array_to_string_(arr) result(str)
909 : real(dp), intent(in) :: arr(:)
910 : character(len=:), allocatable :: str
911 :
912 : character(len=32) :: buf
913 1 : integer :: ii
914 :
915 1 : str = ""
916 4 : do ii = 1, size(arr)
917 3 : write(buf, "(es23.15e3)") arr(ii)
918 5 : if (ii > 1) str = str // " "
919 4 : str = str // trim(adjustl(buf))
920 : end do
921 :
922 1 : end function real_array_to_string_
923 :
924 : !> Convert an integer matrix to newline-delimited rows.
925 2 : function int_matrix_to_string_(mat, nrows, ncols) result(str)
926 : integer, intent(in) :: mat(:,:)
927 : integer, intent(in) :: nrows, ncols
928 : character(len=:), allocatable :: str
929 :
930 : character(len=32) :: buf
931 1 : integer :: ir, ic
932 :
933 1 : str = ""
934 3 : do ir = 1, nrows
935 3 : if (ir > 1) str = str // new_line("a")
936 9 : do ic = 1, ncols
937 6 : write(buf, "(i0)") mat(ic, ir)
938 10 : if (ic > 1) str = str // " "
939 8 : str = str // trim(buf)
940 : end do
941 : end do
942 :
943 1 : end function int_matrix_to_string_
944 :
945 : !> Convert a real(dp) matrix to newline-delimited rows.
946 4 : function real_matrix_to_string_(mat, nrows, ncols) result(str)
947 : real(dp), intent(in) :: mat(:,:)
948 : integer, intent(in) :: nrows, ncols
949 : character(len=:), allocatable :: str
950 :
951 : character(len=32) :: buf
952 2 : integer :: ir, ic
953 :
954 2 : str = ""
955 6 : do ir = 1, nrows
956 6 : if (ir > 1) str = str // new_line("a")
957 18 : do ic = 1, ncols
958 12 : write(buf, "(es23.15e3)") mat(ic, ir)
959 20 : if (ic > 1) str = str // " "
960 16 : str = str // trim(adjustl(buf))
961 : end do
962 : end do
963 :
964 1 : end function real_matrix_to_string_
965 :
966 : !> Convert a complex array buffer to space-separated string.
967 0 : function complex_array_to_string_(buf, nn) result(str)
968 : real(dp), intent(in) :: buf(:,:)
969 : integer, intent(in) :: nn
970 : character(len=:), allocatable :: str
971 :
972 : character(len=64) :: tmp
973 0 : integer :: ii
974 0 : real(dp) :: re, im
975 :
976 0 : str = ""
977 0 : do ii = 1, nn
978 0 : re = buf(1, ii)
979 0 : im = buf(2, ii)
980 0 : if (im >= 0.0_dp) then
981 0 : write(tmp, "(es23.15e3,'+',es23.15e3,'i')") re, im
982 : else
983 0 : write(tmp, "(es23.15e3,es23.15e3,'i')") re, im
984 : end if
985 0 : if (ii > 1) str = str // " "
986 0 : str = str // trim(adjustl(tmp))
987 : end do
988 :
989 2 : end function complex_array_to_string_
990 :
991 : ! ---------------------------------------------------------------------------
992 : ! Utility helpers
993 : ! ---------------------------------------------------------------------------
994 :
995 : !> Ensure a name is safe for HDF5 (non-empty).
996 31 : function safe_name_(name) result(sname)
997 : character(len=:), allocatable, intent(in) :: name
998 : character(len=:), allocatable :: sname
999 :
1000 31 : if (allocated(name)) then
1001 31 : if (len(name) > 0) then
1002 31 : sname = name
1003 : else
1004 0 : sname = "_unnamed"
1005 : end if
1006 : else
1007 0 : sname = "_unnamed"
1008 : end if
1009 :
1010 0 : end function safe_name_
1011 :
1012 : !> Set an error if the optional error argument is present.
1013 0 : subroutine set_error_(error, message)
1014 : type(hsd_error_t), allocatable, intent(out), optional :: error
1015 : character(len=*), intent(in) :: message
1016 :
1017 0 : if (present(error)) then
1018 0 : allocate(error)
1019 0 : error%code = HSD_STAT_IO_ERROR
1020 0 : error%message = message
1021 : end if
1022 :
1023 31 : end subroutine set_error_
1024 :
1025 109 : end module hsd_data_hdf5
|
