Line data Source code
1 : !> Unified HSD API module
2 : !> Merges functionality from accessors, mutators, and query modules.
3 : module hsd_api
4 : use hsd_constants, only: dp
5 : use hsd_utils, only: to_lower, string_buffer_t
6 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_NOT_FOUND, HSD_STAT_TYPE_ERROR
7 : use hsd_types, only: hsd_node_t, hsd_node_ptr_t, new_table, new_value, &
8 : & NODE_TYPE_TABLE, NODE_TYPE_VALUE, &
9 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
10 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
11 : & VALUE_TYPE_COMPLEX
12 : implicit none (type, external)
13 : private
14 :
15 : ! --- Declarations ---
16 : !> HSD query and navigation operations
17 : !>
18 : !> This module provides functionality for navigating HSD tree structures,
19 : !> introspecting node types, and performing tree operations like merging
20 : !> and cloning.
21 :
22 : ! Public types
23 : public :: hsd_node_ptr_t
24 :
25 : ! Public procedures
26 : public :: hsd_get_child, hsd_get_table
27 : public :: hsd_has_child
28 : public :: hsd_remove_child
29 : public :: hsd_get_type, hsd_is_table, hsd_is_value, hsd_is_array
30 : public :: hsd_child_count, hsd_get_keys
31 : public :: hsd_get_attrib, hsd_has_attrib, hsd_set_attrib
32 : public :: hsd_rename_child
33 : public :: hsd_get_choice
34 : public :: hsd_get_children
35 : public :: hsd_get_child_tables
36 : public :: hsd_merge, hsd_clone
37 : public :: hsd_table_equal
38 : public :: hsd_set_processed
39 : public :: hsd_has_value_children
40 : public :: hsd_get_name
41 :
42 : !> HSD data accessors (getters)
43 : !>
44 : !> This module provides interfaces and implementations for retrieving data
45 : !> from HSD tables. It supports type-safe access to scalars, arrays, and
46 : !> matrices.
47 :
48 : ! Public interfaces
49 : public :: hsd_get, hsd_get_or_set, hsd_get_matrix
50 : public :: hsd_get_inline_text
51 :
52 : !> Generic interface for getting values
53 : !>
54 : !> All procedures accept an optional `stat` parameter for error status.
55 : interface hsd_get
56 : module procedure :: hsd_get_string
57 : module procedure :: hsd_get_integer
58 : module procedure :: hsd_get_real_dp
59 : module procedure :: hsd_get_logical
60 : module procedure :: hsd_get_complex_dp
61 : module procedure :: hsd_get_integer_array
62 : module procedure :: hsd_get_real_dp_array
63 : module procedure :: hsd_get_logical_array
64 : module procedure :: hsd_get_string_array
65 : module procedure :: hsd_get_complex_dp_array
66 : end interface hsd_get
67 :
68 : !> Generic interface for getting values with default, writing default back to tree if absent
69 : !>
70 : !> If the key is not found, the default value is
71 : !> written back into the tree. This is critical for generating processed output
72 : !> (e.g., dftb_pin.hsd) that contains all defaults.
73 : !> stat is HSD_STAT_NOT_FOUND when default is used, HSD_STAT_OK when key existed.
74 : interface hsd_get_or_set
75 : module procedure :: hsd_get_or_set_string
76 : module procedure :: hsd_get_or_set_integer
77 : module procedure :: hsd_get_or_set_real_dp
78 : module procedure :: hsd_get_or_set_logical
79 : module procedure :: hsd_get_or_set_complex_dp
80 : module procedure :: hsd_get_or_set_integer_array
81 : module procedure :: hsd_get_or_set_real_dp_array
82 : module procedure :: hsd_get_or_set_logical_array
83 : end interface hsd_get_or_set
84 :
85 : !> Generic interface for getting 2D matrices
86 : interface hsd_get_matrix
87 : module procedure :: hsd_get_integer_matrix
88 : module procedure :: hsd_get_real_dp_matrix
89 : module procedure :: hsd_get_complex_dp_matrix
90 : end interface hsd_get_matrix
91 :
92 : !> HSD data mutators (setters)
93 : !>
94 : !> This module provides interfaces and implementations for modifying HSD tables.
95 : !> It supports type-safe setting of scalars and arrays, with automatic path
96 : !> creation for nested structures.
97 :
98 : ! Public interface
99 : public :: hsd_set
100 : public :: hsd_clear_children
101 :
102 : !> Generic interface for setting values by path
103 : interface hsd_set
104 : module procedure :: hsd_set_string
105 : module procedure :: hsd_set_integer
106 : module procedure :: hsd_set_real_dp
107 : module procedure :: hsd_set_logical
108 : module procedure :: hsd_set_complex_dp
109 : module procedure :: hsd_set_integer_array
110 : module procedure :: hsd_set_real_dp_array
111 : module procedure :: hsd_set_logical_array
112 : module procedure :: hsd_set_complex_dp_array
113 : module procedure :: hsd_set_string_array
114 : module procedure :: hsd_set_integer_matrix
115 : module procedure :: hsd_set_real_dp_matrix
116 : module procedure :: hsd_set_complex_dp_matrix
117 : end interface hsd_set
118 :
119 :
120 : contains
121 :
122 : ! --- Implementations ---
123 :
124 : !> Normalize a path string by removing leading/trailing slashes and collapsing
125 : !> consecutive slashes. E.g. "/Geometry//Periodic/" → "Geometry/Periodic"
126 800 : pure function normalize_path(path) result(normalized)
127 : character(len=*), intent(in) :: path
128 : character(len=:), allocatable :: normalized
129 :
130 800 : integer :: i, n, out_len
131 800 : logical :: prev_was_slash
132 :
133 800 : n = len_trim(path)
134 800 : if (n == 0) then
135 3 : normalized = ""
136 3 : return
137 : end if
138 :
139 : block
140 797 : character(len=n) :: buf
141 797 : out_len = 0
142 797 : prev_was_slash = .true. ! treat start as after slash to skip leading "/"
143 :
144 7725 : do i = 1, n
145 7725 : if (path(i:i) == '/') then
146 220 : if (.not. prev_was_slash) then
147 215 : out_len = out_len + 1
148 215 : buf(out_len:out_len) = '/'
149 : end if
150 220 : prev_was_slash = .true.
151 : else
152 6708 : out_len = out_len + 1
153 6708 : buf(out_len:out_len) = path(i:i)
154 6708 : prev_was_slash = .false.
155 : end if
156 : end do
157 :
158 : ! Remove trailing slash
159 797 : if (out_len > 0) then
160 796 : if (buf(out_len:out_len) == '/') out_len = out_len - 1
161 : end if
162 :
163 797 : if (out_len > 0) then
164 796 : normalized = buf(1:out_len)
165 : else
166 1 : normalized = ""
167 : end if
168 : end block
169 :
170 800 : end function normalize_path
171 :
172 : !> Resolve a path into parent table + leaf name.
173 19 : subroutine resolve_path_parent_(table, path, parent_table, child_name, stat)
174 : type(hsd_node_t), intent(in), target :: table
175 : character(len=*), intent(in) :: path
176 : type(hsd_node_t), pointer, intent(out) :: parent_table
177 : character(len=:), allocatable, intent(out) :: child_name
178 : integer, intent(out) :: stat
179 :
180 : type(hsd_node_t), pointer :: parent_node
181 19 : character(len=:), allocatable :: norm, parent_path
182 19 : integer :: last_slash, local_stat
183 :
184 19 : nullify(parent_table)
185 19 : child_name = ""
186 19 : norm = normalize_path(path)
187 19 : if (len(norm) == 0) then
188 2 : stat = HSD_STAT_NOT_FOUND
189 2 : return
190 : end if
191 :
192 17 : last_slash = index(norm, "/", back=.true.)
193 17 : if (last_slash > 0) then
194 8 : parent_path = norm(1:last_slash-1)
195 8 : child_name = norm(last_slash+1:)
196 8 : call hsd_get_child(table, parent_path, parent_node, local_stat)
197 8 : if (local_stat /= HSD_STAT_OK .or. .not. associated(parent_node)) then
198 1 : stat = HSD_STAT_NOT_FOUND
199 1 : return
200 : end if
201 7 : if (parent_node%node_type == NODE_TYPE_TABLE) then
202 4 : parent_table => parent_node
203 : else
204 3 : stat = HSD_STAT_TYPE_ERROR
205 3 : return
206 : end if
207 : else
208 9 : parent_table => table
209 9 : child_name = norm
210 : end if
211 :
212 13 : stat = HSD_STAT_OK
213 819 : end subroutine resolve_path_parent_
214 :
215 : !> Check if a table has a child with given name
216 26 : function hsd_has_child(table, name) result(has)
217 : type(hsd_node_t), intent(in), target :: table
218 : character(len=*), intent(in) :: name
219 : logical :: has
220 :
221 : type(hsd_node_t), pointer :: child
222 26 : integer :: stat
223 :
224 28 : if (index(name, "/") > 0) then
225 : ! Path-based lookup - navigate through nested tables
226 2 : call hsd_get_child(table, name, child, stat)
227 2 : has = (stat == HSD_STAT_OK .and. associated(child))
228 : else
229 24 : has = table%has_child(name)
230 : end if
231 :
232 45 : end function hsd_has_child
233 :
234 : !> Remove a child from a table by name
235 : !>
236 : !> Supports path-based navigation with "/" separator for nested tables.
237 : !> The last component of the path is the child to remove.
238 7 : subroutine hsd_remove_child(table, path, stat)
239 : type(hsd_node_t), intent(inout), target :: table
240 : character(len=*), intent(in) :: path
241 : integer, intent(out), optional :: stat
242 :
243 : type(hsd_node_t), pointer :: parent_table
244 7 : character(len=:), allocatable :: child_name
245 7 : integer :: local_stat
246 :
247 7 : call resolve_path_parent_(table, path, parent_table, child_name, local_stat)
248 7 : if (local_stat /= HSD_STAT_OK) then
249 2 : if (present(stat)) stat = local_stat
250 2 : return
251 : end if
252 :
253 5 : call parent_table%remove_child_by_name(child_name, local_stat)
254 5 : if (present(stat)) stat = local_stat
255 :
256 33 : end subroutine hsd_remove_child
257 :
258 : !> Get the type of a value at the given path
259 : !>
260 : !> Returns one of: VALUE_TYPE_NONE (not found or is table), VALUE_TYPE_STRING,
261 : !> VALUE_TYPE_INTEGER, VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY,
262 : !> VALUE_TYPE_COMPLEX
263 9 : function hsd_get_type(table, path) result(val_type)
264 : type(hsd_node_t), intent(in), target :: table
265 : character(len=*), intent(in) :: path
266 : integer :: val_type
267 :
268 : type(hsd_node_t), pointer :: child
269 9 : integer :: local_stat
270 :
271 9 : val_type = VALUE_TYPE_NONE
272 9 : call hsd_get_child(table, path, child, local_stat)
273 :
274 9 : if (local_stat /= 0 .or. .not. associated(child)) return
275 :
276 6 : if (child%node_type == NODE_TYPE_VALUE) then
277 5 : val_type = child%value_type
278 : end if
279 :
280 16 : end function hsd_get_type
281 :
282 : !> Check if the node at path is a table (container)
283 20 : function hsd_is_table(table, path) result(is_tbl)
284 : type(hsd_node_t), intent(in), target :: table
285 : character(len=*), intent(in) :: path
286 : logical :: is_tbl
287 :
288 : type(hsd_node_t), pointer :: child
289 20 : integer :: local_stat
290 :
291 20 : is_tbl = .false.
292 20 : call hsd_get_child(table, path, child, local_stat)
293 :
294 20 : if (local_stat /= 0 .or. .not. associated(child)) return
295 :
296 19 : if (child%node_type == NODE_TYPE_TABLE) then
297 18 : is_tbl = .true.
298 : end if
299 :
300 29 : end function hsd_is_table
301 :
302 : !> Check if the node at path is a value (leaf)
303 5 : function hsd_is_value(table, path) result(is_val)
304 : type(hsd_node_t), intent(in), target :: table
305 : character(len=*), intent(in) :: path
306 : logical :: is_val
307 :
308 : type(hsd_node_t), pointer :: child
309 5 : integer :: local_stat
310 :
311 5 : is_val = .false.
312 5 : call hsd_get_child(table, path, child, local_stat)
313 :
314 5 : if (local_stat /= 0 .or. .not. associated(child)) return
315 :
316 4 : if (child%node_type == NODE_TYPE_VALUE) then
317 3 : is_val = .true.
318 : end if
319 :
320 25 : end function hsd_is_value
321 :
322 : !> Check if the node at path contains array data
323 1 : function hsd_is_array(table, path) result(is_arr)
324 : type(hsd_node_t), intent(in), target :: table
325 : character(len=*), intent(in) :: path
326 : logical :: is_arr
327 :
328 2 : is_arr = (hsd_get_type(table, path) == VALUE_TYPE_ARRAY)
329 :
330 6 : end function hsd_is_array
331 :
332 : !> Get the number of children in a table at the given path
333 : !>
334 : !> Returns 0 if path not found or is not a table
335 10 : function hsd_child_count(table, path) result(count)
336 : type(hsd_node_t), intent(in), target :: table
337 : character(len=*), intent(in) :: path
338 : integer :: count
339 :
340 : type(hsd_node_t), pointer :: child
341 10 : integer :: local_stat
342 :
343 10 : count = 0
344 :
345 10 : if (len_trim(path) == 0) then
346 : ! Empty path means the root table itself
347 5 : count = table%num_children
348 5 : return
349 : end if
350 :
351 5 : call hsd_get_child(table, path, child, local_stat)
352 :
353 5 : if (local_stat /= 0 .or. .not. associated(child)) return
354 :
355 5 : if (child%node_type == NODE_TYPE_TABLE) then
356 4 : count = child%num_children
357 : end if
358 :
359 11 : end function hsd_child_count
360 :
361 : !> Get the keys (child names) from a table at the given path
362 9 : subroutine hsd_get_keys(table, path, keys, stat)
363 : type(hsd_node_t), intent(in), target :: table
364 : character(len=*), intent(in) :: path
365 : character(len=:), allocatable, intent(out) :: keys(:)
366 : integer, intent(out), optional :: stat
367 :
368 : type(hsd_node_t), pointer :: child
369 9 : integer :: local_stat
370 :
371 9 : if (present(stat)) stat = HSD_STAT_OK
372 :
373 9 : if (len_trim(path) == 0) then
374 : ! Empty path means the root table itself
375 5 : call table%get_keys(keys)
376 5 : return
377 : end if
378 :
379 4 : call hsd_get_child(table, path, child, local_stat)
380 :
381 4 : if (local_stat /= 0 .or. .not. associated(child)) then
382 1 : allocate(character(len=1) :: keys(0))
383 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
384 1 : return
385 : end if
386 :
387 3 : if (child%node_type == NODE_TYPE_TABLE) then
388 2 : call child%get_keys(keys)
389 : else
390 1 : allocate(character(len=1) :: keys(0))
391 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
392 : end if
393 :
394 19 : end subroutine hsd_get_keys
395 :
396 : !> Get a child node by path (using / as separator)
397 781 : subroutine hsd_get_child(table, path, child, stat)
398 : type(hsd_node_t), intent(in), target :: table
399 : character(len=*), intent(in) :: path
400 : type(hsd_node_t), pointer, intent(out) :: child
401 : integer, intent(out), optional :: stat
402 :
403 781 : character(len=:), allocatable :: norm
404 :
405 781 : child => null()
406 : ! stat will be overriden by subroutine below.
407 770 : if (present(stat)) stat = HSD_STAT_OK
408 :
409 781 : norm = normalize_path(path)
410 781 : if (len(norm) == 0) then
411 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
412 2 : return
413 : end if
414 :
415 : ! Delegate to recursive helper
416 779 : call get_first_child_table(table, norm, child, stat)
417 :
418 790 : end subroutine hsd_get_child
419 :
420 : !> Helper to navigate path and get child
421 978 : recursive subroutine get_first_child_table(table, path, child, stat)
422 : type(hsd_node_t), intent(in), target :: table
423 : character(len=*), intent(in) :: path
424 : type(hsd_node_t), pointer, intent(out) :: child
425 : integer, intent(out), optional :: stat
426 :
427 978 : character(len=:), allocatable :: remaining, segment
428 : type(hsd_node_t), pointer :: current
429 978 : integer :: sep_pos
430 :
431 978 : child => null()
432 978 : remaining = path
433 :
434 : ! Get first segment
435 978 : sep_pos = index(remaining, "/")
436 978 : if (sep_pos > 0) then
437 202 : segment = remaining(1:sep_pos-1)
438 202 : remaining = remaining(sep_pos+1:)
439 : else
440 776 : segment = remaining
441 776 : remaining = ""
442 : end if
443 :
444 : ! Find child with this name
445 978 : call table%get_child_by_name(segment, current)
446 :
447 978 : if (.not. associated(current)) then
448 84 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
449 84 : return
450 : end if
451 :
452 : ! If no more path, return this node
453 894 : if (len_trim(remaining) == 0) then
454 693 : child => current
455 693 : if (present(stat)) stat = HSD_STAT_OK
456 693 : return
457 : end if
458 :
459 : ! Otherwise, recurse into child table
460 201 : if (current%node_type == NODE_TYPE_TABLE) then
461 199 : call get_first_child_table(current, remaining, child, stat)
462 : else
463 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
464 : end if
465 :
466 2737 : end subroutine get_first_child_table
467 :
468 : !> Get a table child by path
469 18 : subroutine hsd_get_table(table, path, child_table, stat)
470 : type(hsd_node_t), intent(in), target :: table
471 : character(len=*), intent(in) :: path
472 : type(hsd_node_t), pointer, intent(out) :: child_table
473 : integer, intent(out), optional :: stat
474 :
475 : type(hsd_node_t), pointer :: child
476 18 : integer :: local_stat
477 :
478 18 : child_table => null()
479 18 : call hsd_get_child(table, path, child, local_stat)
480 :
481 18 : if (associated(child)) then
482 17 : if (child%node_type == NODE_TYPE_TABLE) then
483 5 : child_table => child
484 5 : child_table%processed = .true.
485 5 : if (present(stat)) stat = HSD_STAT_OK
486 : else
487 12 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
488 : end if
489 : else
490 1 : if (present(stat)) stat = local_stat
491 : end if
492 :
493 36 : end subroutine hsd_get_table
494 :
495 : !> Get an attribute from a node at the given path
496 : !>
497 : !> Example: For `LatticeConstant [Angstrom] = 5.4`, the attribute is "Angstrom"
498 11 : subroutine hsd_get_attrib(table, path, attrib, stat)
499 : type(hsd_node_t), intent(in), target :: table
500 : character(len=*), intent(in) :: path
501 : character(len=:), allocatable, intent(out) :: attrib
502 : integer, intent(out), optional :: stat
503 :
504 : type(hsd_node_t), pointer :: child
505 11 : integer :: local_stat
506 :
507 11 : call hsd_get_child(table, path, child, local_stat)
508 :
509 11 : if (local_stat /= 0 .or. .not. associated(child)) then
510 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
511 1 : attrib = ""
512 1 : return
513 : end if
514 :
515 : ! Node exists - return OK regardless of whether attribute is set
516 10 : if (allocated(child%attrib)) then
517 8 : attrib = child%attrib
518 : else
519 2 : attrib = ""
520 : end if
521 10 : if (present(stat)) stat = HSD_STAT_OK
522 :
523 29 : end subroutine hsd_get_attrib
524 :
525 : !> Check if a node at the given path has an attribute
526 5 : function hsd_has_attrib(table, path) result(has)
527 : type(hsd_node_t), intent(in), target :: table
528 : character(len=*), intent(in) :: path
529 : logical :: has
530 :
531 : type(hsd_node_t), pointer :: child
532 5 : integer :: local_stat
533 :
534 5 : has = .false.
535 5 : call hsd_get_child(table, path, child, local_stat)
536 :
537 5 : if (local_stat /= 0 .or. .not. associated(child)) return
538 :
539 4 : has = allocated(child%attrib)
540 :
541 16 : end function hsd_has_attrib
542 :
543 : !> Set an attribute on a node at the given path
544 : !>
545 : !> Example: Setting "Angstrom" on `LatticeConstant` makes it render as
546 : !> `LatticeConstant [Angstrom] = 5.4`
547 2 : subroutine hsd_set_attrib(table, path, attrib, stat)
548 : type(hsd_node_t), intent(inout), target :: table
549 : character(len=*), intent(in) :: path
550 : character(len=*), intent(in) :: attrib
551 : integer, intent(out), optional :: stat
552 :
553 : type(hsd_node_t), pointer :: child
554 2 : integer :: local_stat
555 :
556 2 : call hsd_get_child(table, path, child, local_stat)
557 :
558 2 : if (local_stat /= 0 .or. .not. associated(child)) then
559 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
560 1 : return
561 : end if
562 :
563 1 : child%attrib = attrib
564 1 : if (present(stat)) stat = HSD_STAT_OK
565 :
566 7 : end subroutine hsd_set_attrib
567 :
568 : !> Rename a child of a table
569 : !>
570 : !> Finds the child with `old_name` and changes its name to `new_name`.
571 : !> The child's position in the table is preserved. The name index is
572 : !> invalidated and rebuilt on next lookup.
573 3 : subroutine hsd_rename_child(table, old_name, new_name, stat)
574 : type(hsd_node_t), intent(inout), target :: table
575 : character(len=*), intent(in) :: old_name
576 : character(len=*), intent(in) :: new_name
577 : integer, intent(out), optional :: stat
578 :
579 : type(hsd_node_t), pointer :: child
580 3 : integer :: local_stat
581 : type(hsd_node_t), pointer :: parent_table
582 3 : character(len=:), allocatable :: child_old_name
583 :
584 3 : call resolve_path_parent_(table, old_name, parent_table, child_old_name, local_stat)
585 3 : if (local_stat /= HSD_STAT_OK) then
586 0 : if (present(stat)) stat = local_stat
587 0 : return
588 : end if
589 :
590 : ! Find the child by name
591 3 : call parent_table%get_child_by_name(child_old_name, child)
592 :
593 3 : if (.not. associated(child)) then
594 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
595 1 : return
596 : end if
597 :
598 : ! Rename it
599 2 : child%name = new_name
600 :
601 2 : if (present(stat)) stat = HSD_STAT_OK
602 :
603 5 : end subroutine hsd_rename_child
604 :
605 : !> Get a polymorphic child for dispatch (choice pattern)
606 : !>
607 : !> This is a convenience for the common HSD pattern where a table has a single
608 : !> child whose name is the selector. For example:
609 : !> Driver = ConjugateGradient { ... }
610 : !> Here the child's name ("ConjugateGradient") determines the variant and its
611 : !> contents are the variant's parameters.
612 : !>
613 : !> If `path` is empty, looks at the direct children of `table`.
614 : !> Returns the name and typed table pointer of the first table child found.
615 4 : subroutine hsd_get_choice(table, path, choice_name, choice_table, stat)
616 : type(hsd_node_t), intent(in), target :: table
617 : character(len=*), intent(in) :: path
618 : character(len=:), allocatable, intent(out) :: choice_name
619 : type(hsd_node_t), pointer, intent(out) :: choice_table
620 : integer, intent(out), optional :: stat
621 :
622 : type(hsd_node_t), pointer :: parent_node, child
623 : type(hsd_node_t), pointer :: parent_table
624 4 : integer :: ii, local_stat
625 :
626 4 : choice_name = ""
627 4 : choice_table => null()
628 :
629 : ! Navigate to parent
630 4 : if (len_trim(path) > 0) then
631 4 : call hsd_get_child(table, path, parent_node, local_stat)
632 4 : if (local_stat /= 0 .or. .not. associated(parent_node)) then
633 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
634 1 : return
635 : end if
636 3 : if (parent_node%node_type == NODE_TYPE_TABLE) then
637 3 : parent_table => parent_node
638 : else
639 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
640 0 : return
641 : end if
642 : else
643 0 : parent_table => table
644 : end if
645 :
646 : ! Find first table child
647 4 : do ii = 1, parent_table%num_children
648 2 : call parent_table%get_child(ii, child)
649 2 : if (.not. associated(child)) cycle
650 4 : if (child%node_type == NODE_TYPE_TABLE) then
651 1 : if (allocated(child%name)) then
652 1 : choice_name = to_lower(child%name)
653 : end if
654 1 : choice_table => child
655 1 : choice_table%processed = .true.
656 1 : if (present(stat)) stat = HSD_STAT_OK
657 1 : return
658 : end if
659 : end do
660 :
661 : ! No table child found - check if there's a value child (leaf dispatch)
662 2 : do ii = 1, parent_table%num_children
663 1 : call parent_table%get_child(ii, child)
664 1 : if (.not. associated(child)) cycle
665 2 : if (child%node_type == NODE_TYPE_VALUE) then
666 1 : if (allocated(child%string_value)) then
667 1 : choice_name = to_lower(child%string_value)
668 0 : else if (allocated(child%name)) then
669 0 : choice_name = to_lower(child%name)
670 : end if
671 1 : if (present(stat)) stat = HSD_STAT_OK
672 1 : return
673 : end if
674 : end do
675 :
676 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
677 :
678 7 : end subroutine hsd_get_choice
679 :
680 : !> Get all children of a table that match a given name (case-insensitive)
681 : !>
682 : !> Supports path-based lookup: "Geometry/Atom" will navigate to the
683 : !> "Geometry" table then collect all children named "Atom".
684 : !> Returns an array of hsd_node_ptr_t pointing to the matching children.
685 : !> If no children match, an empty (size-0) array is returned and stat is OK.
686 5 : subroutine hsd_get_children(table, path, children, stat)
687 : type(hsd_node_t), intent(in), target :: table
688 : character(len=*), intent(in) :: path
689 : type(hsd_node_ptr_t), allocatable, intent(out) :: children(:)
690 : integer, intent(out), optional :: stat
691 :
692 5 : call collect_named_children_(table, path, children, stat, tables_only=.false.)
693 :
694 4 : end subroutine hsd_get_children
695 :
696 :
697 : !> Get all table children of a table that match a given name (case-insensitive)
698 : !>
699 : !> Like hsd_get_children but returns only table-type children.
700 : !> Supports path-based lookup: "Geometry/Atom" will navigate to the
701 : !> "Geometry" table then collect all table children named "Atom".
702 : !> If no children match, an empty (size-0) array is returned.
703 4 : subroutine hsd_get_child_tables(table, path, children, stat)
704 : type(hsd_node_t), intent(in), target :: table
705 : character(len=*), intent(in) :: path
706 : type(hsd_node_ptr_t), allocatable, intent(out) :: children(:)
707 : integer, intent(out), optional :: stat
708 :
709 4 : character(len=:), allocatable :: child_name
710 : type(hsd_node_t), pointer :: child
711 : type(hsd_node_t), pointer :: parent_table
712 4 : integer :: local_stat, i, count
713 4 : character(len=:), allocatable :: lower_name
714 :
715 0 : call resolve_path_parent_(table, path, parent_table, child_name, local_stat)
716 4 : if (local_stat /= HSD_STAT_OK) then
717 2 : allocate(children(0))
718 2 : if (present(stat)) stat = local_stat
719 2 : return
720 : end if
721 :
722 2 : lower_name = to_lower(child_name)
723 :
724 : ! First pass: count table matches
725 2 : count = 0
726 8 : do i = 1, parent_table%num_children
727 6 : call parent_table%get_child(i, child)
728 6 : if (.not. associated(child)) cycle
729 6 : if (.not. allocated(child%name)) cycle
730 6 : if (to_lower(child%name) /= lower_name) cycle
731 7 : if (child%node_type == NODE_TYPE_TABLE) then
732 5 : count = count + 1
733 : end if
734 : end do
735 :
736 : ! Allocate result
737 7 : allocate(children(count))
738 :
739 : ! Second pass: fill pointers (table children only)
740 2 : count = 0
741 8 : do i = 1, parent_table%num_children
742 6 : call parent_table%get_child(i, child)
743 6 : if (.not. associated(child)) cycle
744 6 : if (.not. allocated(child%name)) cycle
745 6 : if (to_lower(child%name) /= lower_name) cycle
746 7 : if (child%node_type == NODE_TYPE_TABLE) then
747 5 : count = count + 1
748 5 : children(count)%node => child
749 5 : child%processed = .true.
750 : end if
751 : end do
752 :
753 2 : if (present(stat)) stat = HSD_STAT_OK
754 :
755 13 : end subroutine hsd_get_child_tables
756 :
757 :
758 : !> Merge two HSD tables (overlay pattern)
759 : !>
760 : !> Values from `overlay` are merged into `base`. If a key exists in both,
761 : !> the value from `overlay` takes precedence (unless it's a table,
762 : !> in which case they are merged recursively).
763 19 : recursive subroutine hsd_merge(base, overlay, stat)
764 : type(hsd_node_t), intent(inout) :: base
765 : type(hsd_node_t), intent(in) :: overlay
766 : integer, intent(out), optional :: stat
767 :
768 : type(hsd_node_t), pointer :: overlay_child, base_child
769 19 : type(hsd_node_t) :: cloned_table
770 19 : type(hsd_node_t) :: cloned_value
771 19 : integer :: i, local_stat
772 :
773 19 : if (present(stat)) stat = HSD_STAT_OK
774 :
775 : ! Iterate over overlay children
776 43 : do i = 1, overlay%num_children
777 24 : call overlay%get_child(i, overlay_child)
778 24 : if (.not. associated(overlay_child)) cycle
779 24 : if (.not. allocated(overlay_child%name)) cycle
780 :
781 : ! Check if base has this child
782 24 : call base%get_child_by_name(overlay_child%name, base_child)
783 :
784 43 : if (.not. associated(base_child)) then
785 : ! Child doesn't exist in base - clone and add it
786 8 : if (overlay_child%node_type == NODE_TYPE_TABLE) then
787 2 : call clone_table(overlay_child, cloned_table)
788 2 : call base%add_child(cloned_table)
789 8 : else if (overlay_child%node_type == NODE_TYPE_VALUE) then
790 4 : call clone_value(overlay_child, cloned_value)
791 4 : call base%add_child(cloned_value)
792 : end if
793 : else
794 : ! Child exists - handle based on type
795 18 : if (overlay_child%node_type == NODE_TYPE_TABLE) then
796 : ! If both are tables, merge recursively
797 5 : if (base_child%node_type == NODE_TYPE_TABLE) then
798 5 : call hsd_merge(base_child, overlay_child, local_stat)
799 5 : if (present(stat) .and. local_stat /= HSD_STAT_OK) stat = local_stat
800 : else
801 : ! Base is not a table but overlay is - skip (could log warning)
802 : end if
803 13 : else if (overlay_child%node_type == NODE_TYPE_VALUE) then
804 : ! Overlay value replaces base value
805 26 : if (base_child%node_type == NODE_TYPE_VALUE) then
806 13 : call clone_value(overlay_child, cloned_value)
807 : ! Replace the value content
808 13 : base_child%value_type = cloned_value%value_type
809 : ! Copy attribute from overlay
810 13 : if (allocated(cloned_value%attrib)) then
811 1 : base_child%attrib = cloned_value%attrib
812 : else
813 12 : if (allocated(base_child%attrib)) deallocate(base_child%attrib)
814 : end if
815 : ! Clear stale fields before overwriting
816 13 : if (allocated(base_child%string_value)) &
817 13 : & deallocate(base_child%string_value)
818 : ! Copy new values from clone
819 13 : if (allocated(cloned_value%string_value)) &
820 13 : & base_child%string_value = cloned_value%string_value
821 : else
822 : ! Type mismatch - skip
823 : end if
824 : end if
825 : end if
826 : end do
827 :
828 23 : end subroutine hsd_merge
829 :
830 : !> Clone a table (deep copy)
831 11 : recursive subroutine clone_table(source, dest)
832 : type(hsd_node_t), intent(in) :: source
833 : type(hsd_node_t), intent(out) :: dest
834 :
835 : type(hsd_node_t), pointer :: child
836 11 : type(hsd_node_t) :: cloned_subtable
837 11 : type(hsd_node_t) :: cloned_value
838 11 : integer :: i
839 :
840 11 : call new_table(dest, name=source%name)
841 11 : if (allocated(source%attrib)) dest%attrib = source%attrib
842 11 : dest%line = source%line
843 :
844 26 : do i = 1, source%num_children
845 15 : call source%get_child(i, child)
846 15 : if (.not. associated(child)) cycle
847 :
848 31 : if (child%node_type == NODE_TYPE_TABLE) then
849 5 : call clone_table(child, cloned_subtable)
850 5 : call dest%add_child(cloned_subtable)
851 20 : else if (child%node_type == NODE_TYPE_VALUE) then
852 10 : call clone_value(child, cloned_value)
853 10 : call dest%add_child(cloned_value)
854 : end if
855 : end do
856 :
857 11 : end subroutine clone_table
858 :
859 : !> Clone a value (deep copy)
860 54 : subroutine clone_value(source, dest)
861 : type(hsd_node_t), intent(in) :: source
862 : type(hsd_node_t), intent(out) :: dest
863 :
864 27 : call new_value(dest, name=source%name)
865 27 : if (allocated(source%attrib)) dest%attrib = source%attrib
866 27 : dest%line = source%line
867 27 : dest%value_type = source%value_type
868 :
869 27 : if (allocated(source%string_value)) dest%string_value = source%string_value
870 :
871 27 : end subroutine clone_value
872 :
873 : !> Deep clone an entire HSD table tree
874 8 : subroutine hsd_clone(source, dest, stat)
875 : type(hsd_node_t), intent(in) :: source
876 : type(hsd_node_t), intent(out) :: dest
877 : integer, intent(out), optional :: stat
878 :
879 4 : call clone_table(source, dest)
880 4 : if (present(stat)) stat = HSD_STAT_OK
881 :
882 27 : end subroutine hsd_clone
883 :
884 : !> Compare two HSD tables for structural and value equality
885 : !>
886 : !> Returns .true. if both tables have the same children (by name),
887 : !> the same structure (tables vs values), and the same values.
888 : !> Comparison is recursive for nested tables.
889 : !> Child order does not matter — children are matched by name.
890 : !> Name comparison is case-insensitive to match HSD conventions.
891 17 : recursive function hsd_table_equal(a, b) result(equal)
892 : type(hsd_node_t), intent(in), target :: a
893 : type(hsd_node_t), intent(in), target :: b
894 : logical :: equal
895 :
896 : type(hsd_node_t), pointer :: child_a, child_b
897 17 : integer :: i
898 :
899 17 : equal = .false.
900 :
901 : ! Quick check: same number of children
902 17 : if (a%num_children /= b%num_children) return
903 :
904 : ! Check that every child in a has a matching child in b
905 30 : do i = 1, a%num_children
906 20 : call a%get_child(i, child_a)
907 20 : if (.not. associated(child_a)) return
908 20 : if (.not. allocated(child_a%name)) return
909 :
910 : ! Look for matching child in b
911 20 : call b%get_child_by_name(child_a%name, child_b)
912 20 : if (.not. associated(child_b)) return
913 :
914 : ! Compare node types and values
915 30 : if (.not. nodes_equal(child_a, child_b)) return
916 : end do
917 :
918 10 : equal = .true.
919 :
920 14 : end function hsd_table_equal
921 :
922 : !> Compare two nodes for equality (recursive for tables)
923 20 : recursive function nodes_equal(a, b) result(equal)
924 : type(hsd_node_t), intent(in), target :: a
925 : type(hsd_node_t), intent(in), target :: b
926 : logical :: equal
927 :
928 20 : equal = .false.
929 :
930 : ! Both must be the same dynamic type
931 20 : if (a%node_type == NODE_TYPE_TABLE) then
932 3 : if (b%node_type == NODE_TYPE_TABLE) then
933 3 : equal = hsd_table_equal(a, b)
934 : end if
935 :
936 17 : else if (a%node_type == NODE_TYPE_VALUE) then
937 17 : if (b%node_type == NODE_TYPE_VALUE) then
938 17 : equal = values_equal(a, b)
939 : end if
940 : end if
941 :
942 20 : end function nodes_equal
943 :
944 : !> Compare two value nodes for equality
945 17 : function values_equal(a, b) result(equal)
946 : type(hsd_node_t), intent(in) :: a
947 : type(hsd_node_t), intent(in) :: b
948 : logical :: equal
949 :
950 17 : equal = .false.
951 :
952 : ! Must have the same value type
953 0 : if (a%value_type /= b%value_type) return
954 :
955 : ! Compare string_value
956 17 : if (allocated(a%string_value) .and. allocated(b%string_value)) then
957 17 : if (a%string_value /= b%string_value) return
958 0 : else if (allocated(a%string_value) .neqv. allocated(b%string_value)) then
959 0 : return
960 : end if
961 :
962 13 : equal = .true.
963 :
964 17 : end function values_equal
965 :
966 :
967 : !> Set the processed flag on a table and optionally all its descendants.
968 : !>
969 : !> When `recursive` is `.true.`, walks the entire subtree rooted at `table`
970 : !> and sets `%processed = .true.` on every node (tables and values).
971 : !> When `recursive` is `.false.` (the default), only the given table itself
972 : !> is marked.
973 6 : recursive subroutine hsd_set_processed(table, recursive)
974 : type(hsd_node_t), intent(inout), target :: table
975 : logical, intent(in), optional :: recursive
976 :
977 6 : logical :: do_recurse
978 6 : integer :: ii
979 : type(hsd_node_t), pointer :: child
980 :
981 6 : do_recurse = .false.
982 6 : if (present(recursive)) do_recurse = recursive
983 :
984 6 : table%processed = .true.
985 :
986 6 : if (.not. do_recurse) return
987 :
988 12 : do ii = 1, table%num_children
989 8 : call table%get_child(ii, child)
990 8 : if (.not. associated(child)) cycle
991 :
992 12 : if (child%node_type == NODE_TYPE_TABLE) then
993 2 : call hsd_set_processed(child, recursive=.true.)
994 6 : else if (child%node_type == NODE_TYPE_VALUE) then
995 6 : child%processed = .true.
996 : end if
997 : end do
998 :
999 17 : end subroutine hsd_set_processed
1000 :
1001 :
1002 : !> Check whether a table has any value children (inline data).
1003 3 : function hsd_has_value_children(table) result(has)
1004 : type(hsd_node_t), intent(in), target :: table
1005 : logical :: has
1006 :
1007 3 : integer :: ii
1008 : type(hsd_node_t), pointer :: child
1009 :
1010 3 : has = .false.
1011 4 : do ii = 1, table%num_children
1012 2 : call table%get_child(ii, child)
1013 2 : if (.not. associated(child)) cycle
1014 4 : if (child%node_type == NODE_TYPE_VALUE) then
1015 1 : has = .true.
1016 1 : return
1017 : end if
1018 : end do
1019 :
1020 3 : end function hsd_has_value_children
1021 :
1022 :
1023 : !> Get the lowercased name of a node.
1024 : !>
1025 : !> If the node's name is unset or blank, returns the `default` string
1026 : !> (which itself defaults to "" if not provided).
1027 6 : subroutine hsd_get_name(node, name, default)
1028 : type(hsd_node_t), intent(in) :: node
1029 : character(len=:), allocatable, intent(out) :: name
1030 : character(len=*), intent(in), optional :: default
1031 :
1032 6 : character(len=:), allocatable :: fallback
1033 :
1034 6 : if (present(default)) then
1035 2 : fallback = default
1036 : else
1037 4 : fallback = ""
1038 : end if
1039 :
1040 6 : if (allocated(node%name)) then
1041 2 : if (len_trim(node%name) > 0) then
1042 2 : name = to_lower(node%name)
1043 : else
1044 0 : name = fallback
1045 : end if
1046 : else
1047 4 : name = fallback
1048 : end if
1049 :
1050 9 : end subroutine hsd_get_name
1051 :
1052 : !> Get the inline text VALUE node from a table node.
1053 : !>
1054 : !> Looks for a child named "#text" and returns the hsd_value pointer.
1055 20 : subroutine get_inline_value_(table, val_node, stat)
1056 : type(hsd_node_t), intent(in), target :: table
1057 : type(hsd_node_t), pointer, intent(out) :: val_node
1058 : integer, intent(out) :: stat
1059 :
1060 : type(hsd_node_t), pointer :: child
1061 :
1062 20 : nullify(val_node)
1063 20 : call table%get_child_by_name("#text", child)
1064 20 : if (associated(child)) then
1065 9 : if (child%node_type == NODE_TYPE_VALUE) then
1066 9 : val_node => child
1067 9 : stat = HSD_STAT_OK
1068 9 : return
1069 : end if
1070 : end if
1071 :
1072 11 : stat = HSD_STAT_NOT_FOUND
1073 :
1074 26 : end subroutine get_inline_value_
1075 :
1076 : !> Helper: Get the value node at the given path, handling inline text tables transparently
1077 435 : subroutine get_value_node_(table, path, val_node, stat)
1078 : type(hsd_node_t), intent(in), target :: table
1079 : character(len=*), intent(in) :: path
1080 : type(hsd_node_t), pointer, intent(out) :: val_node
1081 : integer, intent(out) :: stat
1082 :
1083 : type(hsd_node_t), pointer :: child
1084 :
1085 435 : nullify(val_node)
1086 :
1087 435 : call hsd_get_child(table, path, child, stat)
1088 435 : if (stat /= 0 .or. .not. associated(child)) then
1089 32 : stat = HSD_STAT_NOT_FOUND
1090 32 : return
1091 : end if
1092 :
1093 403 : child%processed = .true.
1094 :
1095 403 : if (child%node_type == NODE_TYPE_VALUE) then
1096 394 : val_node => child
1097 394 : stat = HSD_STAT_OK
1098 9 : else if (child%node_type == NODE_TYPE_TABLE) then
1099 : ! Try to extract inline value
1100 9 : call get_inline_value_(child, val_node, stat)
1101 9 : if (stat == HSD_STAT_NOT_FOUND) stat = HSD_STAT_TYPE_ERROR
1102 : else
1103 0 : stat = HSD_STAT_TYPE_ERROR
1104 : end if
1105 455 : end subroutine get_value_node_
1106 :
1107 : !> Get string value by path
1108 42 : subroutine hsd_get_string(table, path, val, stat)
1109 : type(hsd_node_t), intent(in), target :: table
1110 : character(len=*), intent(in) :: path
1111 : character(len=:), allocatable, intent(out) :: val
1112 : integer, intent(out), optional :: stat
1113 :
1114 : type(hsd_node_t), pointer :: vnode
1115 42 : integer :: local_stat
1116 :
1117 42 : call get_value_node_(table, path, vnode, local_stat)
1118 :
1119 42 : if (local_stat == HSD_STAT_OK) then
1120 35 : call vnode%get_string(val, local_stat)
1121 : else
1122 7 : val = ""
1123 : end if
1124 :
1125 42 : if (present(stat)) stat = local_stat
1126 :
1127 435 : end subroutine hsd_get_string
1128 :
1129 : !> Get integer value by path
1130 291 : subroutine hsd_get_integer(table, path, val, stat)
1131 : type(hsd_node_t), intent(in), target :: table
1132 : character(len=*), intent(in) :: path
1133 : integer, intent(out) :: val
1134 : integer, intent(out), optional :: stat
1135 :
1136 : type(hsd_node_t), pointer :: vnode
1137 291 : integer :: local_stat
1138 :
1139 291 : call get_value_node_(table, path, vnode, local_stat)
1140 :
1141 291 : if (local_stat == HSD_STAT_OK) then
1142 282 : call vnode%get_integer(val, local_stat)
1143 : else
1144 9 : val = 0
1145 : end if
1146 :
1147 291 : if (present(stat)) stat = local_stat
1148 42 : end subroutine hsd_get_integer
1149 :
1150 : !> Get double precision real value by path
1151 29 : subroutine hsd_get_real_dp(table, path, val, stat)
1152 : type(hsd_node_t), intent(in), target :: table
1153 : character(len=*), intent(in) :: path
1154 : real(dp), intent(out) :: val
1155 : integer, intent(out), optional :: stat
1156 :
1157 : type(hsd_node_t), pointer :: vnode
1158 29 : integer :: local_stat
1159 :
1160 29 : call get_value_node_(table, path, vnode, local_stat)
1161 :
1162 29 : if (local_stat == HSD_STAT_OK) then
1163 22 : call vnode%get_real(val, local_stat)
1164 : else
1165 7 : val = 0.0_dp
1166 : end if
1167 :
1168 29 : if (present(stat)) stat = local_stat
1169 291 : end subroutine hsd_get_real_dp
1170 :
1171 : !> Get logical value by path
1172 40 : subroutine hsd_get_logical(table, path, val, stat)
1173 : type(hsd_node_t), intent(in), target :: table
1174 : character(len=*), intent(in) :: path
1175 : logical, intent(out) :: val
1176 : integer, intent(out), optional :: stat
1177 :
1178 : type(hsd_node_t), pointer :: vnode
1179 40 : integer :: local_stat
1180 :
1181 40 : call get_value_node_(table, path, vnode, local_stat)
1182 :
1183 40 : if (local_stat == HSD_STAT_OK) then
1184 32 : call vnode%get_logical(val, local_stat)
1185 : else
1186 8 : val = .false.
1187 : end if
1188 :
1189 40 : if (present(stat)) stat = local_stat
1190 29 : end subroutine hsd_get_logical
1191 :
1192 : !> Get complex value by path
1193 33 : subroutine hsd_get_complex_dp(table, path, val, stat)
1194 : type(hsd_node_t), intent(in), target :: table
1195 : character(len=*), intent(in) :: path
1196 : complex(dp), intent(out) :: val
1197 : integer, intent(out), optional :: stat
1198 :
1199 : type(hsd_node_t), pointer :: vnode
1200 33 : integer :: local_stat
1201 :
1202 33 : call get_value_node_(table, path, vnode, local_stat)
1203 :
1204 33 : if (local_stat == HSD_STAT_OK) then
1205 27 : call vnode%get_complex(val, local_stat)
1206 : else
1207 6 : val = (0.0_dp, 0.0_dp)
1208 : end if
1209 :
1210 33 : if (present(stat)) stat = local_stat
1211 40 : end subroutine hsd_get_complex_dp
1212 :
1213 : !> Get integer array by path (supports space/comma/newline separated values)
1214 23 : subroutine hsd_get_integer_array(table, path, val, stat)
1215 : type(hsd_node_t), intent(in), target :: table
1216 : character(len=*), intent(in) :: path
1217 : integer, allocatable, intent(out) :: val(:)
1218 : integer, intent(out), optional :: stat
1219 :
1220 : type(hsd_node_t), pointer :: child
1221 23 : integer :: local_stat
1222 :
1223 23 : call hsd_get_child(table, path, child, local_stat)
1224 :
1225 23 : if (local_stat /= 0 .or. .not. associated(child)) then
1226 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1227 3 : allocate(val(0))
1228 3 : return
1229 : end if
1230 :
1231 20 : child%processed = .true.
1232 :
1233 20 : if (child%node_type == NODE_TYPE_VALUE) then
1234 17 : call child%get_int_array(val, local_stat)
1235 17 : if (present(stat)) stat = local_stat
1236 3 : else if (child%node_type == NODE_TYPE_TABLE) then
1237 3 : block
1238 : type(hsd_node_t), pointer :: vnode
1239 3 : call get_inline_value_(child, vnode, local_stat)
1240 3 : if (local_stat == 0) then
1241 1 : call vnode%get_int_array(val, local_stat)
1242 1 : if (present(stat)) stat = local_stat
1243 : else
1244 2 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1245 2 : allocate(val(0))
1246 : end if
1247 : end block
1248 : else
1249 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1250 0 : allocate(val(0))
1251 : end if
1252 :
1253 56 : end subroutine hsd_get_integer_array
1254 :
1255 : !> Get double precision real array by path
1256 15 : subroutine hsd_get_real_dp_array(table, path, val, stat)
1257 : type(hsd_node_t), intent(in), target :: table
1258 : character(len=*), intent(in) :: path
1259 : real(dp), allocatable, intent(out) :: val(:)
1260 : integer, intent(out), optional :: stat
1261 :
1262 : type(hsd_node_t), pointer :: child
1263 15 : integer :: local_stat
1264 :
1265 15 : call hsd_get_child(table, path, child, local_stat)
1266 :
1267 15 : if (local_stat /= 0 .or. .not. associated(child)) then
1268 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1269 3 : allocate(val(0))
1270 3 : return
1271 : end if
1272 :
1273 12 : child%processed = .true.
1274 :
1275 12 : if (child%node_type == NODE_TYPE_VALUE) then
1276 10 : call child%get_real_array(val, local_stat)
1277 10 : if (present(stat)) stat = local_stat
1278 2 : else if (child%node_type == NODE_TYPE_TABLE) then
1279 2 : block
1280 : type(hsd_node_t), pointer :: vnode
1281 2 : call get_inline_value_(child, vnode, local_stat)
1282 2 : if (local_stat == 0) then
1283 1 : call vnode%get_real_array(val, local_stat)
1284 1 : if (present(stat)) stat = local_stat
1285 : else
1286 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1287 1 : allocate(val(0))
1288 : end if
1289 : end block
1290 : else
1291 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1292 0 : allocate(val(0))
1293 : end if
1294 :
1295 38 : end subroutine hsd_get_real_dp_array
1296 :
1297 : !> Get logical array by path
1298 16 : subroutine hsd_get_logical_array(table, path, val, stat)
1299 : type(hsd_node_t), intent(in), target :: table
1300 : character(len=*), intent(in) :: path
1301 : logical, allocatable, intent(out) :: val(:)
1302 : integer, intent(out), optional :: stat
1303 :
1304 : type(hsd_node_t), pointer :: child
1305 16 : integer :: local_stat
1306 :
1307 16 : call hsd_get_child(table, path, child, local_stat)
1308 :
1309 16 : if (local_stat /= 0 .or. .not. associated(child)) then
1310 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1311 3 : allocate(val(0))
1312 3 : return
1313 : end if
1314 :
1315 13 : child%processed = .true.
1316 :
1317 13 : if (child%node_type == NODE_TYPE_VALUE) then
1318 11 : call child%get_logical_array(val, local_stat)
1319 11 : if (present(stat)) stat = local_stat
1320 2 : else if (child%node_type == NODE_TYPE_TABLE) then
1321 2 : block
1322 : type(hsd_node_t), pointer :: vnode
1323 2 : call get_inline_value_(child, vnode, local_stat)
1324 2 : if (local_stat == 0) then
1325 1 : call vnode%get_logical_array(val, local_stat)
1326 1 : if (present(stat)) stat = local_stat
1327 : else
1328 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1329 1 : allocate(val(0))
1330 : end if
1331 : end block
1332 : else
1333 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1334 0 : allocate(val(0))
1335 : end if
1336 :
1337 31 : end subroutine hsd_get_logical_array
1338 :
1339 : !> Get string array by path (preserves quoted strings)
1340 14 : subroutine hsd_get_string_array(table, path, val, stat)
1341 : type(hsd_node_t), intent(in), target :: table
1342 : character(len=*), intent(in) :: path
1343 : character(len=:), allocatable, intent(out) :: val(:)
1344 : integer, intent(out), optional :: stat
1345 :
1346 : type(hsd_node_t), pointer :: child
1347 14 : integer :: local_stat
1348 :
1349 14 : call hsd_get_child(table, path, child, local_stat)
1350 :
1351 14 : if (local_stat /= 0 .or. .not. associated(child)) then
1352 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1353 1 : allocate(character(len=1) :: val(0))
1354 1 : return
1355 : end if
1356 :
1357 13 : child%processed = .true.
1358 :
1359 13 : if (child%node_type == NODE_TYPE_VALUE) then
1360 11 : call child%get_string_array(val, local_stat)
1361 11 : if (present(stat)) stat = local_stat
1362 2 : else if (child%node_type == NODE_TYPE_TABLE) then
1363 2 : block
1364 : type(hsd_node_t), pointer :: vnode
1365 2 : call get_inline_value_(child, vnode, local_stat)
1366 2 : if (local_stat == 0) then
1367 1 : call vnode%get_string_array(val, local_stat)
1368 1 : if (present(stat)) stat = local_stat
1369 : else
1370 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1371 1 : allocate(character(len=1) :: val(0))
1372 : end if
1373 : end block
1374 : else
1375 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1376 0 : allocate(character(len=1) :: val(0))
1377 : end if
1378 :
1379 30 : end subroutine hsd_get_string_array
1380 :
1381 : !> Get complex array by path
1382 11 : subroutine hsd_get_complex_dp_array(table, path, val, stat)
1383 : type(hsd_node_t), intent(in), target :: table
1384 : character(len=*), intent(in) :: path
1385 : complex(dp), allocatable, intent(out) :: val(:)
1386 : integer, intent(out), optional :: stat
1387 :
1388 : type(hsd_node_t), pointer :: child
1389 11 : integer :: local_stat
1390 :
1391 11 : call hsd_get_child(table, path, child, local_stat)
1392 :
1393 11 : if (local_stat /= 0 .or. .not. associated(child)) then
1394 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1395 1 : allocate(val(0))
1396 1 : return
1397 : end if
1398 :
1399 10 : child%processed = .true.
1400 :
1401 10 : if (child%node_type == NODE_TYPE_VALUE) then
1402 8 : call child%get_complex_array(val, local_stat)
1403 8 : if (present(stat)) stat = local_stat
1404 2 : else if (child%node_type == NODE_TYPE_TABLE) then
1405 2 : block
1406 : type(hsd_node_t), pointer :: vnode
1407 2 : call get_inline_value_(child, vnode, local_stat)
1408 2 : if (local_stat == 0) then
1409 1 : call vnode%get_complex_array(val, local_stat)
1410 1 : if (present(stat)) stat = local_stat
1411 : else
1412 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1413 1 : allocate(val(0))
1414 : end if
1415 : end block
1416 : else
1417 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1418 0 : allocate(val(0))
1419 : end if
1420 :
1421 25 : end subroutine hsd_get_complex_dp_array
1422 :
1423 : !> Get 2D integer matrix by path (rows separated by newlines or semicolons)
1424 : !> Handles both value nodes and table nodes (where content is in unnamed children)
1425 : !>
1426 : !> If `order` is present and set to "column-major", the returned matrix is
1427 : !> transposed so that text rows map to Fortran columns (column-major layout).
1428 : !> Default is text-layout (row-major).
1429 19 : subroutine hsd_get_integer_matrix(table, path, val, nrows, ncols, stat, order)
1430 : type(hsd_node_t), intent(in), target :: table
1431 : character(len=*), intent(in) :: path
1432 : integer, allocatable, intent(out) :: val(:,:)
1433 : integer, intent(out) :: nrows, ncols
1434 : integer, intent(out), optional :: stat
1435 : character(len=*), intent(in), optional :: order
1436 :
1437 : type(hsd_node_t), pointer :: child
1438 19 : integer :: local_stat
1439 :
1440 19 : call hsd_get_child(table, path, child, local_stat)
1441 :
1442 19 : if (local_stat /= 0 .or. .not. associated(child)) then
1443 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1444 1 : allocate(val(0,0))
1445 1 : nrows = 0
1446 1 : ncols = 0
1447 1 : return
1448 : end if
1449 :
1450 18 : child%processed = .true.
1451 :
1452 18 : if (child%node_type == NODE_TYPE_VALUE) then
1453 7 : call child%get_int_matrix(val, nrows, ncols, local_stat)
1454 7 : if (present(stat)) stat = local_stat
1455 11 : else if (child%node_type == NODE_TYPE_TABLE) then
1456 : ! Table nodes store matrix data as unnamed child values
1457 11 : call get_int_matrix_from_table(child, val, nrows, ncols, local_stat)
1458 11 : if (present(stat)) stat = local_stat
1459 : else
1460 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1461 0 : allocate(val(0,0))
1462 0 : nrows = 0
1463 0 : ncols = 0
1464 : end if
1465 :
1466 : ! Transpose if column-major order requested
1467 18 : if (present(order)) then
1468 1 : if (order == "column-major" .and. nrows > 0 .and. ncols > 0) then
1469 1 : block
1470 1 : integer, allocatable :: tmp(:,:)
1471 1 : integer :: swap
1472 1 : allocate(tmp(ncols, nrows))
1473 9 : tmp = transpose(val)
1474 1 : call move_alloc(tmp, val)
1475 1 : swap = nrows
1476 1 : nrows = ncols
1477 1 : ncols = swap
1478 : end block
1479 : end if
1480 : end if
1481 :
1482 30 : end subroutine hsd_get_integer_matrix
1483 :
1484 : !> Get 2D real matrix by path
1485 : !> Handles both value nodes and table nodes (where content is in unnamed children)
1486 : !>
1487 : !> If `order` is present and set to "column-major", the returned matrix is
1488 : !> transposed so that text rows map to Fortran columns (column-major layout).
1489 : !> Default is text-layout (row-major).
1490 15 : subroutine hsd_get_real_dp_matrix(table, path, val, nrows, ncols, stat, order)
1491 : type(hsd_node_t), intent(in), target :: table
1492 : character(len=*), intent(in) :: path
1493 : real(dp), allocatable, intent(out) :: val(:,:)
1494 : integer, intent(out) :: nrows, ncols
1495 : integer, intent(out), optional :: stat
1496 : character(len=*), intent(in), optional :: order
1497 :
1498 : type(hsd_node_t), pointer :: child
1499 15 : integer :: local_stat
1500 :
1501 15 : call hsd_get_child(table, path, child, local_stat)
1502 :
1503 15 : if (local_stat /= 0 .or. .not. associated(child)) then
1504 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1505 1 : allocate(val(0,0))
1506 1 : nrows = 0
1507 1 : ncols = 0
1508 1 : return
1509 : end if
1510 :
1511 14 : child%processed = .true.
1512 :
1513 14 : if (child%node_type == NODE_TYPE_VALUE) then
1514 6 : call child%get_real_matrix(val, nrows, ncols, local_stat)
1515 6 : if (present(stat)) stat = local_stat
1516 8 : else if (child%node_type == NODE_TYPE_TABLE) then
1517 : ! Table nodes store matrix data as unnamed child values
1518 8 : call get_real_matrix_from_table(child, val, nrows, ncols, local_stat)
1519 8 : if (present(stat)) stat = local_stat
1520 : else
1521 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1522 0 : allocate(val(0,0))
1523 0 : nrows = 0
1524 0 : ncols = 0
1525 : end if
1526 :
1527 : ! Transpose if column-major order requested
1528 14 : if (present(order)) then
1529 1 : if (order == "column-major" .and. nrows > 0 .and. ncols > 0) then
1530 1 : block
1531 1 : real(dp), allocatable :: tmp(:,:)
1532 1 : integer :: swap
1533 1 : allocate(tmp(ncols, nrows))
1534 7 : tmp = transpose(val)
1535 1 : call move_alloc(tmp, val)
1536 1 : swap = nrows
1537 1 : nrows = ncols
1538 1 : ncols = swap
1539 : end block
1540 : end if
1541 : end if
1542 :
1543 34 : end subroutine hsd_get_real_dp_matrix
1544 :
1545 : !> Extract integer matrix from table with unnamed value children
1546 11 : subroutine get_int_matrix_from_table(tbl, mat, nrows, ncols, stat)
1547 : type(hsd_node_t), intent(in) :: tbl
1548 : integer, allocatable, intent(out) :: mat(:,:)
1549 : integer, intent(out) :: nrows, ncols, stat
1550 :
1551 : type(hsd_node_t), pointer :: child
1552 11 : character(len=:), allocatable :: combined_text, str_val
1553 11 : integer :: i, local_stat
1554 :
1555 : ! Combine all unnamed value children into single text
1556 11 : combined_text = ""
1557 22 : do i = 1, tbl%num_children
1558 11 : call tbl%get_child(i, child)
1559 22 : if (associated(child)) then
1560 11 : if (child%node_type == NODE_TYPE_VALUE) then
1561 : ! Include unnamed, empty-named, or #text-named value nodes
1562 : block
1563 11 : logical :: is_text_child
1564 11 : is_text_child = .not. allocated(child%name)
1565 11 : if (.not. is_text_child) &
1566 11 : & is_text_child = (len_trim(child%name) == 0 .or. child%name == "#text")
1567 11 : if (is_text_child) then
1568 10 : call child%get_string(str_val, local_stat)
1569 10 : if (local_stat == 0 .and. len_trim(str_val) > 0) then
1570 10 : if (len(combined_text) > 0) then
1571 1 : combined_text = combined_text // char(10) // str_val
1572 : else
1573 9 : combined_text = str_val
1574 : end if
1575 : end if
1576 : end if
1577 : end block
1578 : end if
1579 : end if
1580 : end do
1581 :
1582 11 : if (len_trim(combined_text) == 0) then
1583 2 : allocate(mat(0,0))
1584 2 : nrows = 0
1585 2 : ncols = 0
1586 2 : stat = HSD_STAT_OK
1587 2 : return
1588 : end if
1589 :
1590 : ! Parse the combined text as a matrix
1591 36 : block
1592 9 : type(hsd_node_t) :: temp_val
1593 9 : call new_value(temp_val)
1594 9 : call temp_val%set_raw(combined_text)
1595 9 : call temp_val%get_int_matrix(mat, nrows, ncols, stat)
1596 36 : call temp_val%destroy()
1597 : end block
1598 :
1599 26 : end subroutine get_int_matrix_from_table
1600 :
1601 : !> Extract real matrix from table with unnamed value children
1602 8 : subroutine get_real_matrix_from_table(tbl, mat, nrows, ncols, stat)
1603 : type(hsd_node_t), intent(in) :: tbl
1604 : real(dp), allocatable, intent(out) :: mat(:,:)
1605 : integer, intent(out) :: nrows, ncols, stat
1606 :
1607 : type(hsd_node_t), pointer :: child
1608 8 : character(len=:), allocatable :: combined_text, str_val
1609 8 : integer :: i, local_stat
1610 :
1611 : ! Combine all unnamed value children into single text
1612 8 : combined_text = ""
1613 17 : do i = 1, tbl%num_children
1614 9 : call tbl%get_child(i, child)
1615 17 : if (associated(child)) then
1616 9 : if (child%node_type == NODE_TYPE_VALUE) then
1617 : ! Include unnamed, empty-named, or #text-named value nodes
1618 : block
1619 9 : logical :: is_text_child
1620 9 : is_text_child = .not. allocated(child%name)
1621 9 : if (.not. is_text_child) &
1622 9 : & is_text_child = (len_trim(child%name) == 0 .or. child%name == "#text")
1623 9 : if (is_text_child) then
1624 8 : call child%get_string(str_val, local_stat)
1625 8 : if (local_stat == 0 .and. len_trim(str_val) > 0) then
1626 8 : if (len(combined_text) > 0) then
1627 1 : combined_text = combined_text // char(10) // str_val
1628 : else
1629 7 : combined_text = str_val
1630 : end if
1631 : end if
1632 : end if
1633 : end block
1634 : end if
1635 : end if
1636 : end do
1637 :
1638 8 : if (len_trim(combined_text) == 0) then
1639 1 : allocate(mat(0,0))
1640 1 : nrows = 0
1641 1 : ncols = 0
1642 1 : stat = HSD_STAT_OK
1643 1 : return
1644 : end if
1645 :
1646 : ! Parse the combined text as a matrix
1647 28 : block
1648 7 : type(hsd_node_t) :: temp_val
1649 7 : call new_value(temp_val)
1650 7 : call temp_val%set_raw(combined_text)
1651 7 : call temp_val%get_real_matrix(mat, nrows, ncols, stat)
1652 28 : call temp_val%destroy()
1653 : end block
1654 :
1655 19 : end subroutine get_real_matrix_from_table
1656 :
1657 : !> Get 2D complex matrix by path
1658 : !> Handles both value nodes and table nodes (where content is in unnamed children)
1659 : !>
1660 : !> If `order` is present and set to "column-major", the returned matrix is
1661 : !> transposed so that text rows map to Fortran columns (column-major layout).
1662 : !> Default is text-layout (row-major).
1663 5 : subroutine hsd_get_complex_dp_matrix(table, path, val, nrows, ncols, stat, order)
1664 : type(hsd_node_t), intent(in), target :: table
1665 : character(len=*), intent(in) :: path
1666 : complex(dp), allocatable, intent(out) :: val(:,:)
1667 : integer, intent(out) :: nrows, ncols
1668 : integer, intent(out), optional :: stat
1669 : character(len=*), intent(in), optional :: order
1670 :
1671 : type(hsd_node_t), pointer :: child
1672 5 : integer :: local_stat
1673 :
1674 5 : call hsd_get_child(table, path, child, local_stat)
1675 :
1676 5 : if (local_stat /= 0 .or. .not. associated(child)) then
1677 0 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1678 0 : allocate(val(0,0))
1679 0 : nrows = 0
1680 0 : ncols = 0
1681 0 : return
1682 : end if
1683 :
1684 5 : child%processed = .true.
1685 :
1686 5 : if (child%node_type == NODE_TYPE_VALUE) then
1687 1 : call child%get_complex_matrix(val, nrows, ncols, local_stat)
1688 1 : if (present(stat)) stat = local_stat
1689 4 : else if (child%node_type == NODE_TYPE_TABLE) then
1690 : ! Table nodes store matrix data as unnamed child values
1691 4 : call get_complex_matrix_from_table(child, val, nrows, ncols, local_stat)
1692 4 : if (present(stat)) stat = local_stat
1693 : else
1694 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1695 0 : allocate(val(0,0))
1696 0 : nrows = 0
1697 0 : ncols = 0
1698 : end if
1699 :
1700 : ! Transpose if column-major order requested
1701 5 : if (present(order)) then
1702 1 : if (order == "column-major" .and. nrows > 0 .and. ncols > 0) then
1703 1 : block
1704 1 : complex(dp), allocatable :: tmp(:,:)
1705 1 : integer :: swap
1706 1 : allocate(tmp(ncols, nrows))
1707 9 : tmp = transpose(val)
1708 1 : call move_alloc(tmp, val)
1709 1 : swap = nrows
1710 1 : nrows = ncols
1711 1 : ncols = swap
1712 : end block
1713 : end if
1714 : end if
1715 :
1716 13 : end subroutine hsd_get_complex_dp_matrix
1717 :
1718 : !> Extract complex matrix from table with unnamed value children
1719 4 : subroutine get_complex_matrix_from_table(tbl, mat, nrows, ncols, stat)
1720 : type(hsd_node_t), intent(in) :: tbl
1721 : complex(dp), allocatable, intent(out) :: mat(:,:)
1722 : integer, intent(out) :: nrows, ncols, stat
1723 :
1724 : type(hsd_node_t), pointer :: child
1725 4 : character(len=:), allocatable :: combined_text, str_val
1726 4 : integer :: i, local_stat
1727 :
1728 : ! Combine all unnamed value children into single text
1729 4 : combined_text = ""
1730 7 : do i = 1, tbl%num_children
1731 3 : call tbl%get_child(i, child)
1732 7 : if (associated(child)) then
1733 3 : if (child%node_type == NODE_TYPE_VALUE) then
1734 : ! Include unnamed, empty-named, or #text-named value nodes
1735 : block
1736 3 : logical :: is_text_child
1737 3 : is_text_child = .not. allocated(child%name)
1738 3 : if (.not. is_text_child) &
1739 3 : & is_text_child = (len_trim(child%name) == 0 .or. child%name == "#text")
1740 3 : if (is_text_child) then
1741 3 : call child%get_string(str_val, local_stat)
1742 3 : if (local_stat == 0 .and. len_trim(str_val) > 0) then
1743 3 : if (len(combined_text) > 0) then
1744 0 : combined_text = combined_text // char(10) // str_val
1745 : else
1746 3 : combined_text = str_val
1747 : end if
1748 : end if
1749 : end if
1750 : end block
1751 : end if
1752 : end if
1753 : end do
1754 :
1755 4 : if (len_trim(combined_text) == 0) then
1756 1 : allocate(mat(0,0))
1757 1 : nrows = 0
1758 1 : ncols = 0
1759 1 : stat = HSD_STAT_OK
1760 1 : return
1761 : end if
1762 :
1763 : ! Parse the combined text as a matrix
1764 12 : block
1765 3 : type(hsd_node_t) :: temp_val
1766 3 : call new_value(temp_val)
1767 3 : call temp_val%set_raw(combined_text)
1768 3 : call temp_val%get_complex_matrix(mat, nrows, ncols, stat)
1769 12 : call temp_val%destroy()
1770 : end block
1771 :
1772 9 : end subroutine get_complex_matrix_from_table
1773 :
1774 : ! ===== helpers =====
1775 :
1776 : !> Copy local status into optional output status.
1777 1316 : pure subroutine set_stat_from_local_(local_stat, stat)
1778 : integer, intent(in) :: local_stat
1779 : integer, intent(out), optional :: stat
1780 :
1781 1052 : if (present(stat)) stat = local_stat
1782 4 : end subroutine set_stat_from_local_
1783 :
1784 : !> Common helper for hsd_get_or_set status and optional child return.
1785 26 : subroutine finalize_get_or_set_(table, path, local_stat, stat, child)
1786 : type(hsd_node_t), intent(inout), target :: table
1787 : character(len=*), intent(in) :: path
1788 : integer, intent(in) :: local_stat
1789 : integer, intent(out), optional :: stat
1790 : type(hsd_node_t), pointer, intent(out), optional :: child
1791 :
1792 43 : if (local_stat /= HSD_STAT_OK) then
1793 17 : call set_stat_from_local_(local_stat, stat)
1794 : else
1795 9 : call set_stat_from_local_(HSD_STAT_OK, stat)
1796 : end if
1797 :
1798 26 : if (present(child)) then
1799 11 : call hsd_get_table(table, path, child)
1800 11 : if (.not. associated(child)) child => table
1801 : end if
1802 :
1803 1316 : end subroutine finalize_get_or_set_
1804 :
1805 : !> Get or create a value child; fails with TYPE_ERROR if final node is not a value.
1806 1285 : subroutine get_or_create_value_child_(table, path, vchild, stat)
1807 : type(hsd_node_t), intent(inout), target :: table
1808 : character(len=*), intent(in) :: path
1809 : type(hsd_node_t), pointer, intent(out) :: vchild
1810 : integer, intent(out) :: stat
1811 :
1812 : type(hsd_node_t), pointer :: child
1813 1285 : integer :: local_stat
1814 :
1815 1285 : nullify(vchild)
1816 1285 : call get_or_create_child(table, path, child, local_stat)
1817 1285 : if (local_stat /= HSD_STAT_OK) then
1818 7 : stat = local_stat
1819 7 : return
1820 : end if
1821 :
1822 1278 : if (child%node_type == NODE_TYPE_VALUE) then
1823 1278 : vchild => child
1824 1278 : stat = HSD_STAT_OK
1825 : else
1826 0 : stat = HSD_STAT_TYPE_ERROR
1827 : end if
1828 1311 : end subroutine get_or_create_value_child_
1829 :
1830 : !> Collect child references matching the final path segment.
1831 5 : subroutine collect_named_children_(table, path, children, stat, tables_only)
1832 : type(hsd_node_t), intent(in), target :: table
1833 : character(len=*), intent(in) :: path
1834 : type(hsd_node_ptr_t), allocatable, intent(out) :: children(:)
1835 : integer, intent(out), optional :: stat
1836 : logical, intent(in) :: tables_only
1837 :
1838 5 : character(len=:), allocatable :: child_name
1839 : type(hsd_node_t), pointer :: child
1840 : type(hsd_node_t), pointer :: parent_table
1841 5 : integer :: local_stat, i, count
1842 5 : character(len=:), allocatable :: lower_name
1843 :
1844 0 : call resolve_path_parent_(table, path, parent_table, child_name, local_stat)
1845 5 : if (local_stat /= HSD_STAT_OK) then
1846 2 : allocate(children(0))
1847 2 : call set_stat_from_local_(local_stat, stat)
1848 2 : return
1849 : end if
1850 :
1851 3 : lower_name = to_lower(child_name)
1852 :
1853 3 : count = 0
1854 9 : do i = 1, parent_table%num_children
1855 6 : call parent_table%get_child(i, child)
1856 6 : if (.not. associated(child)) cycle
1857 6 : if (.not. allocated(child%name)) cycle
1858 6 : if (to_lower(child%name) /= lower_name) cycle
1859 7 : if (tables_only) then
1860 0 : if (child%node_type == NODE_TYPE_TABLE) then
1861 0 : count = count + 1
1862 : end if
1863 : else
1864 4 : count = count + 1
1865 : end if
1866 : end do
1867 :
1868 7 : allocate(children(count))
1869 3 : count = 0
1870 9 : do i = 1, parent_table%num_children
1871 6 : call parent_table%get_child(i, child)
1872 6 : if (.not. associated(child)) cycle
1873 6 : if (.not. allocated(child%name)) cycle
1874 6 : if (to_lower(child%name) /= lower_name) cycle
1875 7 : if (tables_only) then
1876 0 : if (child%node_type == NODE_TYPE_TABLE) then
1877 0 : count = count + 1
1878 0 : children(count)%node => child
1879 0 : child%processed = .true.
1880 : end if
1881 : else
1882 4 : count = count + 1
1883 4 : children(count)%node => child
1884 4 : child%processed = .true.
1885 : end if
1886 : end do
1887 :
1888 3 : call set_stat_from_local_(HSD_STAT_OK, stat)
1889 1295 : end subroutine collect_named_children_
1890 :
1891 : !> Mark a named child node as processed
1892 17 : subroutine mark_child_processed_(table, path)
1893 : type(hsd_node_t), intent(inout), target :: table
1894 : character(len=*), intent(in) :: path
1895 :
1896 : type(hsd_node_t), pointer :: child
1897 17 : integer :: local_stat
1898 :
1899 17 : call hsd_get_child(table, path, child, local_stat)
1900 17 : if (local_stat == 0 .and. associated(child)) then
1901 17 : child%processed = .true.
1902 : end if
1903 :
1904 5 : end subroutine mark_child_processed_
1905 :
1906 : ! ===== hsd_get_or_set implementations =====
1907 :
1908 : !> Get string value with default, writing default back to tree if absent
1909 3 : subroutine hsd_get_or_set_string(table, path, val, default, stat, child)
1910 : type(hsd_node_t), intent(inout), target :: table
1911 : character(len=*), intent(in) :: path
1912 : character(len=:), allocatable, intent(out) :: val
1913 : character(len=*), intent(in) :: default
1914 : integer, intent(out), optional :: stat
1915 : type(hsd_node_t), pointer, intent(out), optional :: child
1916 :
1917 3 : integer :: local_stat
1918 :
1919 3 : call hsd_get_string(table, path, val, local_stat)
1920 :
1921 3 : if (local_stat /= 0) then
1922 2 : val = default
1923 2 : call hsd_set(table, path, default)
1924 2 : call mark_child_processed_(table, path)
1925 : end if
1926 :
1927 3 : call finalize_get_or_set_(table, path, local_stat, stat, child)
1928 :
1929 17 : end subroutine hsd_get_or_set_string
1930 :
1931 : !> Get integer value with default, writing default back to tree if absent
1932 4 : subroutine hsd_get_or_set_integer(table, path, val, default, stat, child)
1933 : type(hsd_node_t), intent(inout), target :: table
1934 : character(len=*), intent(in) :: path
1935 : integer, intent(out) :: val
1936 : integer, intent(in) :: default
1937 : integer, intent(out), optional :: stat
1938 : type(hsd_node_t), pointer, intent(out), optional :: child
1939 :
1940 4 : integer :: local_stat
1941 :
1942 4 : call hsd_get_integer(table, path, val, local_stat)
1943 :
1944 4 : if (local_stat /= 0) then
1945 2 : val = default
1946 2 : call hsd_set(table, path, default)
1947 2 : call mark_child_processed_(table, path)
1948 : end if
1949 :
1950 4 : call finalize_get_or_set_(table, path, local_stat, stat, child)
1951 :
1952 3 : end subroutine hsd_get_or_set_integer
1953 :
1954 : !> Get double precision real value with default, writing default back to tree if absent
1955 2 : subroutine hsd_get_or_set_real_dp(table, path, val, default, stat, child)
1956 : type(hsd_node_t), intent(inout), target :: table
1957 : character(len=*), intent(in) :: path
1958 : real(dp), intent(out) :: val
1959 : real(dp), intent(in) :: default
1960 : integer, intent(out), optional :: stat
1961 : type(hsd_node_t), pointer, intent(out), optional :: child
1962 :
1963 2 : integer :: local_stat
1964 :
1965 2 : call hsd_get_real_dp(table, path, val, local_stat)
1966 :
1967 2 : if (local_stat /= 0) then
1968 2 : val = default
1969 2 : call hsd_set(table, path, default)
1970 2 : call mark_child_processed_(table, path)
1971 : end if
1972 :
1973 2 : call finalize_get_or_set_(table, path, local_stat, stat, child)
1974 :
1975 4 : end subroutine hsd_get_or_set_real_dp
1976 :
1977 : !> Get logical value with default, writing default back to tree if absent
1978 4 : subroutine hsd_get_or_set_logical(table, path, val, default, stat, child)
1979 : type(hsd_node_t), intent(inout), target :: table
1980 : character(len=*), intent(in) :: path
1981 : logical, intent(out) :: val
1982 : logical, intent(in) :: default
1983 : integer, intent(out), optional :: stat
1984 : type(hsd_node_t), pointer, intent(out), optional :: child
1985 :
1986 4 : integer :: local_stat
1987 :
1988 4 : call hsd_get_logical(table, path, val, local_stat)
1989 :
1990 4 : if (local_stat /= 0) then
1991 3 : val = default
1992 3 : call hsd_set(table, path, default)
1993 3 : call mark_child_processed_(table, path)
1994 : end if
1995 :
1996 4 : call finalize_get_or_set_(table, path, local_stat, stat, child)
1997 :
1998 2 : end subroutine hsd_get_or_set_logical
1999 :
2000 : !> Get complex value with default, writing default back to tree if absent
2001 3 : subroutine hsd_get_or_set_complex_dp(table, path, val, default, stat, child)
2002 : type(hsd_node_t), intent(inout), target :: table
2003 : character(len=*), intent(in) :: path
2004 : complex(dp), intent(out) :: val
2005 : complex(dp), intent(in) :: default
2006 : integer, intent(out), optional :: stat
2007 : type(hsd_node_t), pointer, intent(out), optional :: child
2008 :
2009 3 : integer :: local_stat
2010 :
2011 3 : call hsd_get_complex_dp(table, path, val, local_stat)
2012 :
2013 3 : if (local_stat /= 0) then
2014 2 : val = default
2015 2 : call hsd_set(table, path, default)
2016 2 : call mark_child_processed_(table, path)
2017 : end if
2018 :
2019 3 : call finalize_get_or_set_(table, path, local_stat, stat, child)
2020 :
2021 4 : end subroutine hsd_get_or_set_complex_dp
2022 :
2023 : !> Get integer array with default, writing default back to tree if absent
2024 6 : subroutine hsd_get_or_set_integer_array(table, path, val, default, stat, child)
2025 : type(hsd_node_t), intent(inout), target :: table
2026 : character(len=*), intent(in) :: path
2027 : integer, allocatable, intent(out) :: val(:)
2028 : integer, intent(in) :: default(:)
2029 : integer, intent(out), optional :: stat
2030 : type(hsd_node_t), pointer, intent(out), optional :: child
2031 :
2032 3 : integer :: local_stat
2033 :
2034 3 : call hsd_get_integer_array(table, path, val, local_stat)
2035 :
2036 3 : if (local_stat /= 0) then
2037 8 : val = default
2038 2 : call hsd_set(table, path, default)
2039 2 : call mark_child_processed_(table, path)
2040 : end if
2041 :
2042 3 : call finalize_get_or_set_(table, path, local_stat, stat, child)
2043 :
2044 3 : end subroutine hsd_get_or_set_integer_array
2045 :
2046 : !> Get double precision real array with default, writing default back to tree if absent
2047 6 : subroutine hsd_get_or_set_real_dp_array(table, path, val, default, stat, child)
2048 : type(hsd_node_t), intent(inout), target :: table
2049 : character(len=*), intent(in) :: path
2050 : real(dp), allocatable, intent(out) :: val(:)
2051 : real(dp), intent(in) :: default(:)
2052 : integer, intent(out), optional :: stat
2053 : type(hsd_node_t), pointer, intent(out), optional :: child
2054 :
2055 3 : integer :: local_stat
2056 :
2057 3 : call hsd_get_real_dp_array(table, path, val, local_stat)
2058 :
2059 3 : if (local_stat /= 0) then
2060 6 : val = default
2061 2 : call hsd_set(table, path, default)
2062 2 : call mark_child_processed_(table, path)
2063 : end if
2064 :
2065 3 : call finalize_get_or_set_(table, path, local_stat, stat, child)
2066 :
2067 3 : end subroutine hsd_get_or_set_real_dp_array
2068 :
2069 : !> Get logical array with default, writing default back to tree if absent
2070 8 : subroutine hsd_get_or_set_logical_array(table, path, val, default, stat, child)
2071 : type(hsd_node_t), intent(inout), target :: table
2072 : character(len=*), intent(in) :: path
2073 : logical, allocatable, intent(out) :: val(:)
2074 : logical, intent(in) :: default(:)
2075 : integer, intent(out), optional :: stat
2076 : type(hsd_node_t), pointer, intent(out), optional :: child
2077 :
2078 4 : integer :: local_stat
2079 :
2080 4 : call hsd_get_logical_array(table, path, val, local_stat)
2081 :
2082 4 : if (local_stat /= 0) then
2083 7 : val = default
2084 2 : call hsd_set(table, path, default)
2085 2 : call mark_child_processed_(table, path)
2086 : end if
2087 :
2088 4 : call finalize_get_or_set_(table, path, local_stat, stat, child)
2089 :
2090 3 : end subroutine hsd_get_or_set_logical_array
2091 :
2092 :
2093 : !> Get concatenated text content of all unnamed value children.
2094 : !>
2095 : !> Iterates children of `table`, collecting text from unnamed or "#text"
2096 : !> `hsd_value` nodes. Multiple values are separated by spaces.
2097 3 : subroutine hsd_get_inline_text(table, text, stat)
2098 : type(hsd_node_t), intent(in), target :: table
2099 : character(len=:), allocatable, intent(out) :: text
2100 : integer, intent(out), optional :: stat
2101 :
2102 3 : integer :: ii, local_stat
2103 : type(hsd_node_t), pointer :: child
2104 3 : character(len=:), allocatable :: piece
2105 :
2106 3 : text = ""
2107 8 : do ii = 1, table%num_children
2108 5 : call table%get_child(ii, child)
2109 5 : if (.not. associated(child)) cycle
2110 8 : if (child%node_type == NODE_TYPE_VALUE) then
2111 : block
2112 4 : logical :: is_anon_val
2113 4 : is_anon_val = .true.
2114 4 : if (allocated(child%name)) then
2115 3 : if (len_trim(child%name) > 0 .and. child%name /= "#text") then
2116 0 : is_anon_val = .false.
2117 : end if
2118 : end if
2119 4 : if (is_anon_val) then
2120 4 : call child%get_string(piece, local_stat)
2121 4 : if (local_stat == HSD_STAT_OK .and. allocated(piece)) then
2122 4 : if (len(text) > 0) then
2123 2 : text = text // " " // piece
2124 : else
2125 2 : text = piece
2126 : end if
2127 : end if
2128 : end if
2129 : end block
2130 : end if
2131 : end do
2132 :
2133 3 : if (present(stat)) then
2134 3 : if (len(text) > 0) then
2135 2 : stat = HSD_STAT_OK
2136 : else
2137 1 : stat = HSD_STAT_NOT_FOUND
2138 : end if
2139 : end if
2140 :
2141 7 : end subroutine hsd_get_inline_text
2142 :
2143 :
2144 : !> Set string value by path
2145 22 : subroutine hsd_set_string(table, path, val, stat)
2146 : type(hsd_node_t), intent(inout) :: table
2147 : character(len=*), intent(in) :: path
2148 : character(len=*), intent(in) :: val
2149 : integer, intent(out), optional :: stat
2150 :
2151 : type(hsd_node_t), pointer :: vchild
2152 22 : integer :: local_stat
2153 :
2154 22 : call get_or_create_value_child_(table, path, vchild, local_stat)
2155 :
2156 22 : if (local_stat /= HSD_STAT_OK) then
2157 2 : call set_stat_from_local_(local_stat, stat)
2158 2 : return
2159 : end if
2160 :
2161 20 : call vchild%set_string(val)
2162 20 : call set_stat_from_local_(HSD_STAT_OK, stat)
2163 :
2164 25 : end subroutine hsd_set_string
2165 :
2166 : !> Set integer value by path
2167 1231 : subroutine hsd_set_integer(table, path, val, stat)
2168 : type(hsd_node_t), intent(inout) :: table
2169 : character(len=*), intent(in) :: path
2170 : integer, intent(in) :: val
2171 : integer, intent(out), optional :: stat
2172 :
2173 : type(hsd_node_t), pointer :: vchild
2174 1231 : integer :: local_stat
2175 :
2176 1231 : call get_or_create_value_child_(table, path, vchild, local_stat)
2177 :
2178 1231 : if (local_stat /= HSD_STAT_OK) then
2179 2 : call set_stat_from_local_(local_stat, stat)
2180 2 : return
2181 : end if
2182 :
2183 1229 : call vchild%set_integer(val)
2184 1229 : call set_stat_from_local_(HSD_STAT_OK, stat)
2185 :
2186 1253 : end subroutine hsd_set_integer
2187 :
2188 : !> Set double precision real value by path
2189 12 : subroutine hsd_set_real_dp(table, path, val, stat)
2190 : type(hsd_node_t), intent(inout) :: table
2191 : character(len=*), intent(in) :: path
2192 : real(dp), intent(in) :: val
2193 : integer, intent(out), optional :: stat
2194 :
2195 : type(hsd_node_t), pointer :: vchild
2196 12 : integer :: local_stat
2197 :
2198 12 : call get_or_create_value_child_(table, path, vchild, local_stat)
2199 :
2200 12 : if (local_stat /= HSD_STAT_OK) then
2201 1 : call set_stat_from_local_(local_stat, stat)
2202 1 : return
2203 : end if
2204 :
2205 11 : call vchild%set_real(val)
2206 11 : call set_stat_from_local_(HSD_STAT_OK, stat)
2207 :
2208 1243 : end subroutine hsd_set_real_dp
2209 :
2210 : !> Set logical value by path
2211 12 : subroutine hsd_set_logical(table, path, val, stat)
2212 : type(hsd_node_t), intent(inout) :: table
2213 : character(len=*), intent(in) :: path
2214 : logical, intent(in) :: val
2215 : integer, intent(out), optional :: stat
2216 :
2217 : type(hsd_node_t), pointer :: vchild
2218 12 : integer :: local_stat
2219 :
2220 12 : call get_or_create_value_child_(table, path, vchild, local_stat)
2221 :
2222 12 : if (local_stat /= HSD_STAT_OK) then
2223 1 : call set_stat_from_local_(local_stat, stat)
2224 1 : return
2225 : end if
2226 :
2227 11 : call vchild%set_logical(val)
2228 11 : call set_stat_from_local_(HSD_STAT_OK, stat)
2229 :
2230 24 : end subroutine hsd_set_logical
2231 :
2232 : !> Set complex value by path
2233 8 : subroutine hsd_set_complex_dp(table, path, val, stat)
2234 : type(hsd_node_t), intent(inout) :: table
2235 : character(len=*), intent(in) :: path
2236 : complex(dp), intent(in) :: val
2237 : integer, intent(out), optional :: stat
2238 :
2239 : type(hsd_node_t), pointer :: vchild
2240 8 : integer :: local_stat
2241 :
2242 8 : call get_or_create_value_child_(table, path, vchild, local_stat)
2243 :
2244 8 : if (local_stat /= HSD_STAT_OK) then
2245 1 : call set_stat_from_local_(local_stat, stat)
2246 1 : return
2247 : end if
2248 :
2249 7 : call vchild%set_complex(val)
2250 7 : call set_stat_from_local_(HSD_STAT_OK, stat)
2251 :
2252 20 : end subroutine hsd_set_complex_dp
2253 :
2254 : !> Set integer array by path
2255 12 : subroutine hsd_set_integer_array(table, path, val, stat)
2256 : type(hsd_node_t), intent(inout) :: table
2257 : character(len=*), intent(in) :: path
2258 : integer, intent(in) :: val(:)
2259 : integer, intent(out), optional :: stat
2260 :
2261 : type(hsd_node_t), pointer :: child
2262 6 : integer :: local_stat, i
2263 : character(len=32) :: buffer
2264 6 : type(string_buffer_t) :: buf
2265 :
2266 6 : call get_or_create_child(table, path, child, local_stat)
2267 :
2268 6 : if (local_stat /= 0) then
2269 1 : if (present(stat)) stat = local_stat
2270 1 : return
2271 : end if
2272 :
2273 5 : if (child%node_type == NODE_TYPE_VALUE) then
2274 5 : call buf%init()
2275 22 : do i = 1, size(val)
2276 17 : write(buffer, '(I0)') val(i)
2277 17 : if (i > 1) call buf%append_char(' ')
2278 22 : call buf%append_str(trim(adjustl(buffer)))
2279 : end do
2280 5 : call child%set_raw(buf%get_string())
2281 : else
2282 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2283 0 : return
2284 : end if
2285 :
2286 5 : if (present(stat)) stat = HSD_STAT_OK
2287 :
2288 14 : end subroutine hsd_set_integer_array
2289 :
2290 : !> Set double precision real array by path
2291 10 : subroutine hsd_set_real_dp_array(table, path, val, stat)
2292 : type(hsd_node_t), intent(inout) :: table
2293 : character(len=*), intent(in) :: path
2294 : real(dp), intent(in) :: val(:)
2295 : integer, intent(out), optional :: stat
2296 :
2297 : type(hsd_node_t), pointer :: child
2298 5 : integer :: local_stat, i
2299 : character(len=32) :: buffer
2300 5 : type(string_buffer_t) :: buf
2301 :
2302 5 : call get_or_create_child(table, path, child, local_stat)
2303 :
2304 5 : if (local_stat /= 0) then
2305 1 : if (present(stat)) stat = local_stat
2306 1 : return
2307 : end if
2308 :
2309 4 : if (child%node_type == NODE_TYPE_VALUE) then
2310 4 : call buf%init()
2311 13 : do i = 1, size(val)
2312 9 : write(buffer, '(G0)') val(i)
2313 9 : if (i > 1) call buf%append_char(' ')
2314 13 : call buf%append_str(trim(adjustl(buffer)))
2315 : end do
2316 4 : call child%set_raw(buf%get_string())
2317 : else
2318 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2319 0 : return
2320 : end if
2321 :
2322 4 : if (present(stat)) stat = HSD_STAT_OK
2323 :
2324 11 : end subroutine hsd_set_real_dp_array
2325 :
2326 : !> Set logical array by path
2327 12 : subroutine hsd_set_logical_array(table, path, val, stat)
2328 : type(hsd_node_t), intent(inout) :: table
2329 : character(len=*), intent(in) :: path
2330 : logical, intent(in) :: val(:)
2331 : integer, intent(out), optional :: stat
2332 :
2333 : type(hsd_node_t), pointer :: child
2334 6 : integer :: local_stat, i
2335 6 : type(string_buffer_t) :: buf
2336 :
2337 6 : call get_or_create_child(table, path, child, local_stat)
2338 :
2339 6 : if (local_stat /= 0) then
2340 1 : if (present(stat)) stat = local_stat
2341 1 : return
2342 : end if
2343 :
2344 5 : if (child%node_type == NODE_TYPE_VALUE) then
2345 5 : call buf%init()
2346 18 : do i = 1, size(val)
2347 13 : if (i > 1) call buf%append_char(' ')
2348 18 : if (val(i)) then
2349 8 : call buf%append_str("Yes")
2350 : else
2351 5 : call buf%append_str("No")
2352 : end if
2353 : end do
2354 5 : call child%set_raw(buf%get_string())
2355 : else
2356 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2357 0 : return
2358 : end if
2359 :
2360 5 : if (present(stat)) stat = HSD_STAT_OK
2361 :
2362 11 : end subroutine hsd_set_logical_array
2363 :
2364 : !> Set complex array by path
2365 8 : subroutine hsd_set_complex_dp_array(table, path, val, stat)
2366 : type(hsd_node_t), intent(inout) :: table
2367 : character(len=*), intent(in) :: path
2368 : complex(dp), intent(in) :: val(:)
2369 : integer, intent(out), optional :: stat
2370 :
2371 : type(hsd_node_t), pointer :: child
2372 4 : integer :: local_stat, i
2373 : character(len=64) :: buffer
2374 4 : type(string_buffer_t) :: buf
2375 :
2376 4 : call get_or_create_child(table, path, child, local_stat)
2377 :
2378 4 : if (local_stat /= 0) then
2379 1 : if (present(stat)) stat = local_stat
2380 1 : return
2381 : end if
2382 :
2383 3 : if (child%node_type == NODE_TYPE_VALUE) then
2384 3 : call buf%init()
2385 8 : do i = 1, size(val)
2386 5 : if (i > 1) call buf%append_char(' ')
2387 5 : if (aimag(val(i)) >= 0.0_dp) then
2388 4 : write(buffer, '(G0,"+",G0,"i")') real(val(i)), aimag(val(i))
2389 : else
2390 1 : write(buffer, '(G0,G0,"i")') real(val(i)), aimag(val(i))
2391 : end if
2392 8 : call buf%append_str(trim(adjustl(buffer)))
2393 : end do
2394 3 : call child%set_raw(buf%get_string())
2395 : else
2396 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2397 0 : return
2398 : end if
2399 :
2400 3 : if (present(stat)) stat = HSD_STAT_OK
2401 :
2402 10 : end subroutine hsd_set_complex_dp_array
2403 :
2404 : !> Set string array by path
2405 6 : subroutine hsd_set_string_array(table, path, val, stat)
2406 : type(hsd_node_t), intent(inout) :: table
2407 : character(len=*), intent(in) :: path
2408 : character(len=*), intent(in) :: val(:)
2409 : integer, intent(out), optional :: stat
2410 :
2411 : type(hsd_node_t), pointer :: child
2412 3 : integer :: local_stat, i
2413 3 : type(string_buffer_t) :: buf
2414 :
2415 3 : call get_or_create_child(table, path, child, local_stat)
2416 :
2417 3 : if (local_stat /= 0) then
2418 0 : if (present(stat)) stat = local_stat
2419 0 : return
2420 : end if
2421 :
2422 3 : if (child%node_type == NODE_TYPE_VALUE) then
2423 3 : call buf%init()
2424 10 : do i = 1, size(val)
2425 7 : if (i > 1) call buf%append_char(' ')
2426 : ! Quote strings containing spaces
2427 10 : if (index(val(i), ' ') > 0) then
2428 4 : call buf%append_char('"')
2429 4 : call buf%append_str(trim(val(i)))
2430 4 : call buf%append_char('"')
2431 : else
2432 3 : call buf%append_str(trim(val(i)))
2433 : end if
2434 : end do
2435 3 : call child%set_raw(buf%get_string())
2436 : else
2437 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2438 0 : return
2439 : end if
2440 :
2441 3 : if (present(stat)) stat = HSD_STAT_OK
2442 :
2443 7 : end subroutine hsd_set_string_array
2444 :
2445 : !> Set integer matrix by path
2446 2 : subroutine hsd_set_integer_matrix(table, path, val, stat)
2447 : type(hsd_node_t), intent(inout) :: table
2448 : character(len=*), intent(in) :: path
2449 : integer, intent(in) :: val(:,:)
2450 : integer, intent(out), optional :: stat
2451 :
2452 : type(hsd_node_t), pointer :: child
2453 1 : integer :: local_stat, ir, ic
2454 : character(len=32) :: buffer
2455 1 : type(string_buffer_t) :: buf
2456 :
2457 1 : call get_or_create_child(table, path, child, local_stat)
2458 :
2459 1 : if (local_stat /= 0) then
2460 0 : if (present(stat)) stat = local_stat
2461 0 : return
2462 : end if
2463 :
2464 1 : if (child%node_type == NODE_TYPE_VALUE) then
2465 1 : call buf%init()
2466 3 : do ir = 1, size(val, 1)
2467 2 : if (ir > 1) call buf%append_str(new_line('a'))
2468 9 : do ic = 1, size(val, 2)
2469 6 : write(buffer, '(I0)') val(ir, ic)
2470 6 : if (ic > 1) call buf%append_char(' ')
2471 8 : call buf%append_str(trim(adjustl(buffer)))
2472 : end do
2473 : end do
2474 1 : call child%set_raw(buf%get_string())
2475 : else
2476 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2477 0 : return
2478 : end if
2479 :
2480 1 : if (present(stat)) stat = HSD_STAT_OK
2481 :
2482 4 : end subroutine hsd_set_integer_matrix
2483 :
2484 : !> Set double precision real matrix by path
2485 4 : subroutine hsd_set_real_dp_matrix(table, path, val, stat)
2486 : type(hsd_node_t), intent(inout) :: table
2487 : character(len=*), intent(in) :: path
2488 : real(dp), intent(in) :: val(:,:)
2489 : integer, intent(out), optional :: stat
2490 :
2491 : type(hsd_node_t), pointer :: child
2492 2 : integer :: local_stat, ir, ic
2493 : character(len=32) :: buffer
2494 2 : type(string_buffer_t) :: buf
2495 :
2496 2 : call get_or_create_child(table, path, child, local_stat)
2497 :
2498 2 : if (local_stat /= 0) then
2499 0 : if (present(stat)) stat = local_stat
2500 0 : return
2501 : end if
2502 :
2503 2 : if (child%node_type == NODE_TYPE_VALUE) then
2504 2 : call buf%init()
2505 6 : do ir = 1, size(val, 1)
2506 4 : if (ir > 1) call buf%append_str(new_line('a'))
2507 14 : do ic = 1, size(val, 2)
2508 8 : write(buffer, '(G0)') val(ir, ic)
2509 8 : if (ic > 1) call buf%append_char(' ')
2510 12 : call buf%append_str(trim(adjustl(buffer)))
2511 : end do
2512 : end do
2513 2 : call child%set_raw(buf%get_string())
2514 : else
2515 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2516 0 : return
2517 : end if
2518 :
2519 2 : if (present(stat)) stat = HSD_STAT_OK
2520 :
2521 3 : end subroutine hsd_set_real_dp_matrix
2522 :
2523 : !> Set complex double precision matrix by path
2524 2 : subroutine hsd_set_complex_dp_matrix(table, path, val, stat)
2525 : type(hsd_node_t), intent(inout) :: table
2526 : character(len=*), intent(in) :: path
2527 : complex(dp), intent(in) :: val(:,:)
2528 : integer, intent(out), optional :: stat
2529 :
2530 : type(hsd_node_t), pointer :: child
2531 1 : integer :: local_stat, ir, ic
2532 : character(len=64) :: buffer
2533 1 : type(string_buffer_t) :: buf
2534 :
2535 1 : call get_or_create_child(table, path, child, local_stat)
2536 :
2537 1 : if (local_stat /= 0) then
2538 0 : if (present(stat)) stat = local_stat
2539 0 : return
2540 : end if
2541 :
2542 1 : if (child%node_type == NODE_TYPE_VALUE) then
2543 1 : call buf%init()
2544 3 : do ir = 1, size(val, 1)
2545 2 : if (ir > 1) call buf%append_str(new_line('a'))
2546 9 : do ic = 1, size(val, 2)
2547 6 : if (ic > 1) call buf%append_char(' ')
2548 6 : if (aimag(val(ir, ic)) >= 0.0_dp) then
2549 5 : write(buffer, '(G0,"+",G0,"i")') real(val(ir, ic)), aimag(val(ir, ic))
2550 : else
2551 1 : write(buffer, '(G0,G0,"i")') real(val(ir, ic)), aimag(val(ir, ic))
2552 : end if
2553 8 : call buf%append_str(trim(adjustl(buffer)))
2554 : end do
2555 : end do
2556 1 : call child%set_raw(buf%get_string())
2557 : else
2558 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
2559 0 : return
2560 : end if
2561 :
2562 1 : if (present(stat)) stat = HSD_STAT_OK
2563 :
2564 3 : end subroutine hsd_set_complex_dp_matrix
2565 :
2566 : !> Get or create a child node by path, creating intermediate tables as needed
2567 1313 : subroutine get_or_create_child(table, path, child, stat)
2568 : type(hsd_node_t), intent(inout), target :: table
2569 : character(len=*), intent(in) :: path
2570 : type(hsd_node_t), pointer, intent(out) :: child
2571 : integer, intent(out), optional :: stat
2572 :
2573 1313 : character(len=:), allocatable :: remaining, segment
2574 : type(hsd_node_t), pointer :: current
2575 : type(hsd_node_t), pointer :: current_table
2576 1313 : type(hsd_node_t) :: new_tbl
2577 1313 : type(hsd_node_t) :: new_val
2578 1313 : integer :: sep_pos, i
2579 :
2580 1313 : child => null()
2581 1313 : remaining = path
2582 1313 : current_table => table
2583 :
2584 1314 : do while (len_trim(remaining) > 0)
2585 : ! Get next segment
2586 1313 : sep_pos = index(remaining, "/")
2587 1313 : if (sep_pos > 0) then
2588 11 : segment = remaining(1:sep_pos-1)
2589 11 : remaining = remaining(sep_pos+1:)
2590 : else
2591 1302 : segment = remaining
2592 1302 : remaining = ""
2593 : end if
2594 :
2595 : ! Look for existing child
2596 1313 : call current_table%get_child_by_name(segment, current)
2597 :
2598 1313 : if (.not. associated(current)) then
2599 : ! Need to create node
2600 1295 : if (len_trim(remaining) > 0) then
2601 : ! More path segments: create table
2602 1 : call new_table(new_tbl, name=to_lower(segment))
2603 1 : call current_table%add_child(new_tbl)
2604 : ! Get the newly added child
2605 1 : do i = current_table%num_children, 1, -1
2606 1 : call current_table%get_child(i, current)
2607 1 : if (associated(current)) then
2608 1 : if (allocated(current%name)) then
2609 1 : if (to_lower(current%name) == to_lower(segment)) exit
2610 : end if
2611 : end if
2612 : end do
2613 : else
2614 : ! Final segment: create value node
2615 1294 : call new_value(new_val, name=to_lower(segment))
2616 1294 : call current_table%add_child(new_val)
2617 : ! Get the newly added child
2618 1294 : do i = current_table%num_children, 1, -1
2619 1294 : call current_table%get_child(i, current)
2620 1294 : if (associated(current)) then
2621 1294 : if (allocated(current%name)) then
2622 1294 : if (to_lower(current%name) == to_lower(segment)) exit
2623 : end if
2624 : end if
2625 : end do
2626 1294 : child => current
2627 1294 : if (present(stat)) stat = HSD_STAT_OK
2628 1294 : return
2629 : end if
2630 : end if
2631 :
2632 : ! Navigate deeper if more path remains
2633 19 : if (len_trim(remaining) > 0) then
2634 11 : if (current%node_type == NODE_TYPE_TABLE) then
2635 1 : current_table => current
2636 : else
2637 : ! Path segment is not a table, cannot navigate
2638 10 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
2639 10 : return
2640 : end if
2641 : else
2642 8 : child => current
2643 8 : if (present(stat)) stat = HSD_STAT_OK
2644 8 : return
2645 : end if
2646 : end do
2647 :
2648 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
2649 :
2650 1314 : end subroutine get_or_create_child
2651 :
2652 :
2653 : !> Remove all children from a table node.
2654 : !>
2655 : !> After this call, the table has zero children. The children array and hash
2656 : !> index are fully deallocated so subsequent add_child calls re-initialize
2657 : !> correctly.
2658 1 : subroutine hsd_clear_children(table)
2659 : type(hsd_node_t), intent(inout) :: table
2660 :
2661 1 : integer :: ii
2662 : type(hsd_node_t), pointer :: child
2663 :
2664 : ! Destroy each child node
2665 4 : do ii = 1, table%num_children
2666 3 : call table%get_child(ii, child)
2667 4 : if (associated(child)) then
2668 3 : call child%destroy()
2669 3 : deallocate(table%children(ii)%node)
2670 : end if
2671 : end do
2672 :
2673 1 : table%num_children = 0
2674 1 : if (allocated(table%children)) deallocate(table%children)
2675 :
2676 1313 : end subroutine hsd_clear_children
2677 :
2678 :
2679 217 : end module hsd_api
|
