Line data Source code
1 : !> Data types for HSD nodes
2 : !>
3 : !> This module provides the tree structure for representing parsed HSD data.
4 : !> The main types are:
5 : !> - hsd_node - Abstract base type for all nodes
6 : !> - hsd_table - Table (container) node for nested structures
7 : !> - hsd_value - Value (leaf) node for scalar and array data
8 : !> - hsd_iterator - Iterator for traversing table children
9 : !>
10 : !> ## Cache-on-Read Mutation Behavior
11 : !>
12 : !> **IMPORTANT:** Some "read" operations on `hsd_value` (such as `value_get_int_array`,
13 : !> `value_get_real_array`, etc.) use `intent(inout)` and mutate the internal state by
14 : !> caching parsed array results.
15 : !>
16 : !> - The first call parses the raw text and stores it in a cache (e.g., `self%int_array`).
17 : !> - Subsequent calls return the cached array without reparsing.
18 : !> - This means these logically read-only operations have side effects, requiring
19 : !> `intent(inout)`.
20 : !>
21 : !> ### Thread Safety Implications
22 : !>
23 : !> - **Not thread-safe for concurrent reads:** If multiple threads access the same
24 : !> `hsd_value` concurrently, a race may occur on first access (cache population).
25 : !> - **Safe after first access:** Once populated, concurrent reads are safe (immutable).
26 : !> - **Workaround:** If thread safety is required, populate caches in a single-threaded
27 : !> context before concurrent access, or use external synchronization.
28 : !>
29 : !> ### Rationale
30 : !>
31 : !> - This design avoids repeated parsing and improves performance for repeated access.
32 : !> - Purely read-only (side-effect-free) variants could be added in the future if needed.
33 : !>
34 : !> See also: [AGENTS.md](../AGENTS.md) for design notes and thread safety summary.
35 : !> ## Memory Ownership Semantics
36 : !>
37 : !> The HSD tree uses a **copy-on-add** ownership model:
38 : !>
39 : !> - **table_add_child**: Creates a deep copy of the node via `allocate(source=child)`.
40 : !> The caller retains ownership of the original node and is responsible for
41 : !> deallocating it. The table owns the copy and will deallocate it when the
42 : !> table is destroyed or the child is removed.
43 : !>
44 : !> - **table_get_child, table_get_child_by_name**: Return pointers to nodes owned
45 : !> by the table. These pointers become invalid if the child is removed or the
46 : !> table is destroyed. Do NOT deallocate returned pointers.
47 : !>
48 : !> - **table_remove_child**: Deallocates the removed node. Any pointers previously
49 : !> obtained via get_child become invalid.
50 : !>
51 : !> - **table_destroy**: Recursively deallocates all children. Must be called
52 : !> explicitly to avoid memory leaks (Fortran finalizers are not used).
53 : !>
54 : !> ### Example - Proper Memory Management
55 : !>
56 : !> ```fortran
57 : !> type(hsd_table) :: root, child_table
58 : !> type(hsd_value) :: val
59 : !>
60 : !> call new_table(root, "root")
61 : !> call new_value(val, "key")
62 : !> call val%set_string("value")
63 : !> call root%add_child(val) ! root now owns a COPY of val
64 : !> ! val can be reused or will be cleaned up when it goes out of scope
65 : !>
66 : !> call new_table(child_table, "section")
67 : !> call root%add_child(child_table) ! root owns a COPY
68 : !>
69 : !> ! When done, destroy the root (also destroys all children):
70 : !> call root%destroy()
71 : !> ```
72 : module hsd_types
73 : use hsd_constants, only: dp, sp
74 : use hsd_utils, only: to_lower
75 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_TYPE_ERROR, HSD_STAT_NOT_FOUND
76 : use hsd_hash_table, only: hsd_name_index_t
77 : implicit none (type, external)
78 : private
79 :
80 : public :: hsd_node, hsd_table, hsd_value, hsd_node_ptr, hsd_iterator
81 : public :: new_table, new_value
82 : public :: VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER
83 : public :: VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY
84 : public :: VALUE_TYPE_COMPLEX
85 :
86 : !> Value type enumeration
87 : integer, parameter :: VALUE_TYPE_NONE = 0
88 : integer, parameter :: VALUE_TYPE_STRING = 1
89 : integer, parameter :: VALUE_TYPE_INTEGER = 2
90 : integer, parameter :: VALUE_TYPE_REAL = 3
91 : integer, parameter :: VALUE_TYPE_LOGICAL = 4
92 : integer, parameter :: VALUE_TYPE_ARRAY = 5
93 : integer, parameter :: VALUE_TYPE_COMPLEX = 6
94 :
95 : !> Abstract base type for all HSD nodes
96 : type, abstract :: hsd_node
97 : !> Node name (tag name)
98 : character(len=:), allocatable :: name
99 : !> Optional attribute (e.g., unit)
100 : character(len=:), allocatable :: attrib
101 : !> Line number where this node was defined (for error messages)
102 : integer :: line = 0
103 : contains
104 : procedure :: has_attrib => node_has_attrib
105 : procedure :: get_attrib => node_get_attrib
106 : procedure(node_destroy), deferred :: destroy
107 : end type hsd_node
108 :
109 : abstract interface
110 : subroutine node_destroy(self)
111 : import :: hsd_node
112 : implicit none (type, external)
113 : class(hsd_node), intent(inout) :: self
114 : end subroutine node_destroy
115 : end interface
116 :
117 : !> Pointer wrapper for polymorphic node storage
118 : type :: hsd_node_ptr
119 : class(hsd_node), allocatable :: node
120 : end type hsd_node_ptr
121 :
122 : !> Iterator for traversing table children
123 : type :: hsd_iterator
124 : !> Reference to the table being iterated
125 : type(hsd_table), pointer :: table => null()
126 : !> Current position (0 = before first)
127 : integer :: pos = 0
128 : contains
129 : procedure :: init => iterator_init
130 : procedure :: next => iterator_next
131 : procedure :: reset => iterator_reset
132 : procedure :: has_next => iterator_has_next
133 : end type hsd_iterator
134 :
135 : !> Table node (container for child nodes)
136 : type, extends(hsd_node) :: hsd_table
137 : !> Child nodes
138 : type(hsd_node_ptr), allocatable :: children(:)
139 : !> Number of children
140 : integer :: num_children = 0
141 : !> Allocated capacity
142 : integer :: capacity = 0
143 : !> Optional hash index for O(1) child lookup (built when num_children >= threshold)
144 : type(hsd_name_index_t) :: name_index
145 : !> Whether the hash index is active
146 : logical :: index_active = .false.
147 : contains
148 : procedure :: build_index => table_build_index
149 : procedure :: invalidate_index => table_invalidate_index
150 : procedure :: add_child => table_add_child
151 : procedure :: get_child => table_get_child
152 : procedure :: get_child_by_name => table_get_child_by_name
153 : procedure :: has_child => table_has_child
154 : procedure :: num_children_func => table_num_children
155 : procedure :: remove_child => table_remove_child
156 : procedure :: remove_child_by_name => table_remove_child_by_name
157 : procedure :: destroy => table_destroy
158 : procedure :: get_keys => table_get_keys
159 : end type hsd_table
160 :
161 : !> Value node (leaf node with data)
162 : type, extends(hsd_node) :: hsd_value
163 : !> Type of value stored
164 : integer :: value_type = VALUE_TYPE_NONE
165 : !> String value
166 : character(len=:), allocatable :: string_value
167 : !> Integer value
168 : integer :: int_value = 0
169 : !> Real value
170 : real(dp) :: real_value = 0.0_dp
171 : !> Logical value
172 : logical :: logical_value = .false.
173 : !> Complex value
174 : complex(dp) :: complex_value = (0.0_dp, 0.0_dp)
175 : !> Complex array values
176 : complex(dp), allocatable :: complex_array(:)
177 : !> String array (for multi-value or matrix data)
178 : character(len=:), allocatable :: raw_text
179 : !> Integer array values
180 : integer, allocatable :: int_array(:)
181 : !> Real array values
182 : real(dp), allocatable :: real_array(:)
183 : !> Logical array values
184 : logical, allocatable :: logical_array(:)
185 : !> String array values
186 : character(len=:), allocatable :: string_array(:)
187 : !> 2D integer matrix
188 : integer, allocatable :: int_matrix(:,:)
189 : !> 2D real matrix
190 : real(dp), allocatable :: real_matrix(:,:)
191 : !> Number of rows (for matrix data)
192 : integer :: nrows = 0
193 : !> Number of columns (for matrix data)
194 : integer :: ncols = 0
195 : contains
196 : procedure :: set_string => value_set_string
197 : procedure :: set_integer => value_set_integer
198 : procedure :: set_real => value_set_real
199 : procedure :: set_logical => value_set_logical
200 : procedure :: set_complex => value_set_complex
201 : procedure :: set_raw => value_set_raw
202 : procedure :: get_string => value_get_string
203 : procedure :: get_integer => value_get_integer
204 : procedure :: get_real => value_get_real
205 : procedure :: get_logical => value_get_logical
206 : procedure :: get_complex => value_get_complex
207 : procedure :: get_int_array => value_get_int_array
208 : procedure :: get_real_array => value_get_real_array
209 : procedure :: get_logical_array => value_get_logical_array
210 : procedure :: get_string_array => value_get_string_array
211 : procedure :: get_complex_array => value_get_complex_array
212 : procedure :: get_int_matrix => value_get_int_matrix
213 : procedure :: get_real_matrix => value_get_real_matrix
214 : procedure :: destroy => value_destroy
215 : end type hsd_value
216 :
217 : contains
218 :
219 : !> Check if node has an attribute
220 21161 : pure function node_has_attrib(self) result(has)
221 : class(hsd_node), intent(in) :: self
222 : logical :: has
223 21161 : has = allocated(self%attrib)
224 42322 : end function node_has_attrib
225 :
226 : !> Get node attribute (empty string if not set)
227 1010 : pure function node_get_attrib(self) result(attrib)
228 : class(hsd_node), intent(in) :: self
229 : character(len=:), allocatable :: attrib
230 1010 : if (allocated(self%attrib)) then
231 1009 : attrib = self%attrib
232 : else
233 1 : attrib = ""
234 : end if
235 21161 : end function node_get_attrib
236 :
237 : !> Create a new table
238 162475 : subroutine new_table(table, name, attrib, line)
239 : type(hsd_table), intent(out) :: table
240 : character(len=*), intent(in), optional :: name
241 : character(len=*), intent(in), optional :: attrib
242 : integer, intent(in), optional :: line
243 :
244 78605 : if (present(name)) table%name = name
245 78605 : if (present(attrib)) then
246 9422 : if (len_trim(attrib) > 0) table%attrib = attrib
247 : end if
248 78605 : if (present(line)) table%line = line
249 :
250 78605 : table%capacity = 8
251 707445 : allocate(table%children(table%capacity))
252 78605 : table%num_children = 0
253 :
254 1010 : end subroutine new_table
255 :
256 : !> Create a new value node
257 975626 : subroutine new_value(val, name, attrib, line)
258 : type(hsd_value), intent(out) :: val
259 : character(len=*), intent(in), optional :: name
260 : character(len=*), intent(in), optional :: attrib
261 : integer, intent(in), optional :: line
262 :
263 487813 : if (present(name)) val%name = name
264 487813 : if (present(attrib)) then
265 11701 : if (len_trim(attrib) > 0) val%attrib = attrib
266 : end if
267 487813 : if (present(line)) val%line = line
268 487813 : val%value_type = VALUE_TYPE_NONE
269 :
270 78605 : end subroutine new_value
271 :
272 : !> Build the hash index for O(1) child lookup
273 : !>
274 : !> This is called automatically when adding children.
275 : !> Can also be called explicitly to pre-build the index.
276 78548 : subroutine table_build_index(self)
277 : class(hsd_table), intent(inout) :: self
278 :
279 78548 : integer :: i
280 :
281 78548 : call self%name_index%init(self%num_children * 2)
282 :
283 157100 : do i = 1, self%num_children
284 157100 : if (allocated(self%children(i)%node)) then
285 78552 : if (allocated(self%children(i)%node%name)) then
286 78538 : call self%name_index%insert(self%children(i)%node%name, i)
287 : end if
288 : end if
289 : end do
290 :
291 78548 : self%index_active = .true.
292 :
293 487813 : end subroutine table_build_index
294 :
295 : !> Invalidate the hash index (called when children are removed)
296 1 : subroutine table_invalidate_index(self)
297 : class(hsd_table), intent(inout) :: self
298 :
299 1 : if (self%index_active) then
300 1 : call self%name_index%clear()
301 1 : self%index_active = .false.
302 : end if
303 :
304 78548 : end subroutine table_invalidate_index
305 :
306 : !> Add a child node to the table
307 : !>
308 : !> Creates a deep copy of the child node and adds it to the table.
309 : !> The table takes ownership of the copy and will deallocate it when
310 : !> the table is destroyed or the child is removed.
311 : !>
312 : !> @param[inout] self The table to add the child to
313 : !> @param[in] child The child node to copy and add
314 : !>
315 : !> @note The caller retains ownership of the original `child` argument.
316 : !> The copy mechanism uses `allocate(source=child)` which performs
317 : !> a deep copy of all components, including allocatable arrays.
318 : !>
319 : !> ## Performance
320 : !>
321 : !> Uses a hash index for O(1) name lookups.
322 564274 : subroutine table_add_child(self, child)
323 : class(hsd_table), intent(inout) :: self
324 : class(hsd_node), intent(in) :: child
325 :
326 564274 : type(hsd_node_ptr), allocatable :: tmp(:)
327 564274 : integer :: new_capacity
328 :
329 : ! Grow array if needed
330 564274 : if (self%num_children >= self%capacity) then
331 46 : new_capacity = self%capacity * 2
332 6462 : allocate(tmp(new_capacity))
333 3254 : tmp(1:self%num_children) = self%children(1:self%num_children)
334 3300 : call move_alloc(tmp, self%children)
335 46 : self%capacity = new_capacity
336 : end if
337 :
338 : ! Add child
339 564274 : self%num_children = self%num_children + 1
340 564274 : allocate(self%children(self%num_children)%node, source=child)
341 :
342 : ! Update hash index
343 564274 : if (.not. self%index_active) then
344 78542 : call self%build_index()
345 485732 : else if (allocated(child%name)) then
346 485732 : call self%name_index%insert(child%name, self%num_children)
347 : end if
348 :
349 564275 : end subroutine table_add_child
350 :
351 : !> Get child by index
352 : !>
353 : !> Returns a pointer to the child at the given index. The pointer is owned
354 : !> by the table - do NOT deallocate it. The pointer becomes invalid if the
355 : !> child is removed or the table is destroyed.
356 : !>
357 : !> @param[in] self The table to search
358 : !> @param[in] index 1-based index of the child (1 to num_children)
359 : !> @param[out] child Pointer to the child, or null() if index is out of range
360 557358 : subroutine table_get_child(self, index, child)
361 : class(hsd_table), intent(in), target :: self
362 : integer, intent(in) :: index
363 : class(hsd_node), pointer, intent(out) :: child
364 :
365 557358 : child => null()
366 557358 : if (index >= 1 .and. index <= self%num_children) then
367 557357 : if (allocated(self%children(index)%node)) then
368 557357 : child => self%children(index)%node
369 : end if
370 : end if
371 :
372 564274 : end subroutine table_get_child
373 :
374 : !> Get child by name
375 : !>
376 : !> Returns a pointer to the first child with the given name. The pointer is
377 : !> owned by the table - do NOT deallocate it. The pointer becomes invalid if
378 : !> the child is removed or the table is destroyed.
379 : !>
380 : !> @param[in] self The table to search
381 : !> @param[in] name Name to search for
382 : !> @param[out] child Pointer to the child, or null() if not found
383 : !> @param[in] case_insensitive If .true., ignore case when comparing names
384 : !>
385 : !> ## Performance
386 : !>
387 : !> Uses O(1) hash lookup for all table sizes.
388 1811719 : subroutine table_get_child_by_name(self, name, child, case_insensitive)
389 : class(hsd_table), intent(in), target :: self
390 : character(len=*), intent(in) :: name
391 : class(hsd_node), pointer, intent(out) :: child
392 : logical, intent(in), optional :: case_insensitive
393 :
394 1811719 : integer :: idx
395 1811719 : logical :: ignore_case, found
396 :
397 1811719 : child => null()
398 1811719 : ignore_case = .false.
399 611697 : if (present(case_insensitive)) ignore_case = case_insensitive
400 :
401 : ! Ensure index is built if there are children but index isn't active
402 : ! (Should normally be active if added via add_child, but safety first)
403 : if (.not. self%index_active .and. self%num_children > 0) then
404 : ! Deeply constant intent(in) self prevents calling build_index directly
405 : ! but we can use a select type or just assume it's active.
406 : ! Since this is intent(in), we can't build it here.
407 : ! Let's assume it IS active if num_children > 0.
408 : end if
409 :
410 1811719 : if (self%index_active) then
411 1811687 : if (ignore_case) then
412 611666 : idx = self%name_index%lookup_case_insensitive(name, found)
413 : else
414 1200021 : idx = self%name_index%lookup(name, found)
415 : end if
416 :
417 1811687 : if (found .and. idx >= 1 .and. idx <= self%num_children) then
418 1810592 : if (allocated(self%children(idx)%node)) then
419 1810592 : child => self%children(idx)%node
420 : end if
421 : end if
422 : end if
423 :
424 557358 : end subroutine table_get_child_by_name
425 :
426 : !> Check if table has a child with given name
427 15 : function table_has_child(self, name, case_insensitive) result(has)
428 : class(hsd_table), intent(in) :: self
429 : character(len=*), intent(in) :: name
430 : logical, intent(in), optional :: case_insensitive
431 : logical :: has
432 :
433 : class(hsd_node), pointer :: child
434 :
435 15 : call self%get_child_by_name(name, child, case_insensitive)
436 15 : has = associated(child)
437 :
438 1811734 : end function table_has_child
439 :
440 : !> Get number of children
441 2 : pure function table_num_children(self) result(n)
442 : class(hsd_table), intent(in) :: self
443 : integer :: n
444 2 : n = self%num_children
445 15 : end function table_num_children
446 :
447 : !> Get list of all child names
448 9 : subroutine table_get_keys(self, keys)
449 : class(hsd_table), intent(in) :: self
450 : character(len=:), allocatable, intent(out) :: keys(:)
451 :
452 9 : integer :: i, max_len
453 :
454 : ! Find maximum key length
455 9 : max_len = 0
456 23 : do i = 1, self%num_children
457 23 : if (allocated(self%children(i)%node)) then
458 14 : if (allocated(self%children(i)%node%name)) then
459 12 : max_len = max(max_len, len(self%children(i)%node%name))
460 : end if
461 : end if
462 : end do
463 :
464 : ! Allocate and fill keys
465 9 : if (max_len > 0) then
466 6 : allocate(character(len=max_len) :: keys(self%num_children))
467 20 : do i = 1, self%num_children
468 20 : if (allocated(self%children(i)%node)) then
469 14 : if (allocated(self%children(i)%node%name)) then
470 12 : keys(i) = self%children(i)%node%name
471 : else
472 2 : keys(i) = ""
473 : end if
474 : end if
475 : end do
476 : else
477 3 : allocate(character(len=1) :: keys(0))
478 : end if
479 :
480 2 : end subroutine table_get_keys
481 :
482 : !> Remove child at given index
483 : !>
484 : !> Removes and deallocates the child at the given index. Children after
485 : !> the removed one are shifted to fill the gap. Any pointers to the removed
486 : !> child (obtained via get_child) become invalid after this call.
487 : !>
488 : !> @param[inout] self The table to modify
489 : !> @param[in] index 1-based index of the child to remove
490 : !> @param[out] stat Optional status: HSD_STAT_OK on success,
491 : !> HSD_STAT_NOT_FOUND if index is out of range
492 11 : subroutine table_remove_child(self, index, stat)
493 : class(hsd_table), intent(inout) :: self
494 : integer, intent(in) :: index
495 : integer, intent(out), optional :: stat
496 :
497 11 : integer :: i
498 :
499 11 : if (index < 1 .or. index > self%num_children) then
500 4 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
501 4 : return
502 : end if
503 :
504 : ! Destroy the child node
505 7 : if (allocated(self%children(index)%node)) then
506 7 : call self%children(index)%node%destroy()
507 14 : deallocate(self%children(index)%node)
508 : end if
509 :
510 : ! Shift remaining children down
511 14 : do i = index, self%num_children - 1
512 14 : call move_alloc(self%children(i + 1)%node, self%children(i)%node)
513 : end do
514 :
515 7 : self%num_children = self%num_children - 1
516 :
517 : ! Rebuild index as indices have shifted
518 7 : if (self%num_children > 0) then
519 6 : call self%build_index()
520 : else
521 1 : call self%invalidate_index()
522 : end if
523 :
524 7 : if (present(stat)) stat = HSD_STAT_OK
525 :
526 11 : end subroutine table_remove_child
527 :
528 : !> Remove child by name
529 10 : subroutine table_remove_child_by_name(self, name, stat, case_insensitive)
530 : class(hsd_table), intent(inout) :: self
531 : character(len=*), intent(in) :: name
532 : integer, intent(out), optional :: stat
533 : logical, intent(in), optional :: case_insensitive
534 :
535 10 : integer :: idx
536 10 : logical :: ignore_case, found
537 :
538 10 : ignore_case = .false.
539 1 : if (present(case_insensitive)) ignore_case = case_insensitive
540 :
541 10 : if (self%index_active) then
542 10 : if (ignore_case) then
543 1 : idx = self%name_index%lookup_case_insensitive(name, found)
544 : else
545 9 : idx = self%name_index%lookup(name, found)
546 : end if
547 10 : if (found) then
548 6 : call self%remove_child(idx, stat)
549 6 : return
550 : end if
551 : end if
552 :
553 4 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
554 :
555 21 : end subroutine table_remove_child_by_name
556 :
557 : !> Destroy table and all children
558 : !>
559 : !> Recursively deallocates all child nodes and frees all allocated memory.
560 : !> This must be called explicitly to avoid memory leaks - Fortran finalizers
561 : !> are not used for performance reasons. After calling destroy(), the table
562 : !> can be reused by calling new_table().
563 : !>
564 : !> @param[inout] self The table to destroy
565 : !>
566 : !> @warning Any pointers to children obtained via get_child become invalid.
567 78596 : recursive subroutine table_destroy(self)
568 : class(hsd_table), intent(inout) :: self
569 78596 : integer :: i
570 :
571 : ! Destroy hash index
572 78596 : call self%name_index%destroy()
573 78596 : self%index_active = .false.
574 :
575 642860 : do i = 1, self%num_children
576 642860 : if (allocated(self%children(i)%node)) then
577 564264 : call self%children(i)%node%destroy()
578 1128528 : deallocate(self%children(i)%node)
579 : end if
580 : end do
581 :
582 789159 : if (allocated(self%children)) deallocate(self%children)
583 78596 : if (allocated(self%name)) deallocate(self%name)
584 78596 : if (allocated(self%attrib)) deallocate(self%attrib)
585 :
586 78596 : self%num_children = 0
587 78596 : self%capacity = 0
588 :
589 10 : end subroutine table_destroy
590 :
591 : !> Initialize iterator for a table
592 7 : subroutine iterator_init(self, table)
593 : class(hsd_iterator), intent(inout) :: self
594 : type(hsd_table), target, intent(in) :: table
595 :
596 7 : self%table => table
597 7 : self%pos = 0
598 :
599 7 : end subroutine iterator_init
600 :
601 : !> Advance to next child and return it
602 : !> Returns .false. if no more children
603 22 : function iterator_next(self, child) result(has_more)
604 : class(hsd_iterator), intent(inout) :: self
605 : class(hsd_node), pointer, intent(out) :: child
606 : logical :: has_more
607 :
608 22 : child => null()
609 22 : has_more = .false.
610 :
611 1 : if (.not. associated(self%table)) return
612 :
613 21 : self%pos = self%pos + 1
614 21 : if (self%pos <= self%table%num_children) then
615 19 : if (allocated(self%table%children(self%pos)%node)) then
616 19 : child => self%table%children(self%pos)%node
617 19 : has_more = .true.
618 : end if
619 : end if
620 :
621 22 : end function iterator_next
622 :
623 : !> Reset iterator to beginning
624 3 : subroutine iterator_reset(self)
625 : class(hsd_iterator), intent(inout) :: self
626 3 : self%pos = 0
627 22 : end subroutine iterator_reset
628 :
629 : !> Check if there are more children without advancing
630 26 : function iterator_has_next(self) result(has_more)
631 : class(hsd_iterator), intent(in) :: self
632 : logical :: has_more
633 :
634 26 : has_more = .false.
635 26 : if (associated(self%table)) then
636 26 : has_more = self%pos < self%table%num_children
637 : end if
638 :
639 26 : end function iterator_has_next
640 :
641 : !> Set string value
642 10609 : subroutine value_set_string(self, val)
643 : class(hsd_value), intent(inout) :: self
644 : character(len=*), intent(in) :: val
645 10609 : self%value_type = VALUE_TYPE_STRING
646 10609 : self%string_value = val
647 26 : end subroutine value_set_string
648 :
649 : !> Set integer value
650 5854 : subroutine value_set_integer(self, val)
651 : class(hsd_value), intent(inout) :: self
652 : integer, intent(in) :: val
653 5854 : self%value_type = VALUE_TYPE_INTEGER
654 5854 : self%int_value = val
655 10609 : end subroutine value_set_integer
656 :
657 : !> Set real value
658 19 : subroutine value_set_real(self, val)
659 : class(hsd_value), intent(inout) :: self
660 : real(dp), intent(in) :: val
661 19 : self%value_type = VALUE_TYPE_REAL
662 19 : self%real_value = val
663 5873 : end subroutine value_set_real
664 :
665 : !> Set logical value
666 8 : subroutine value_set_logical(self, val)
667 : class(hsd_value), intent(inout) :: self
668 : logical, intent(in) :: val
669 8 : self%value_type = VALUE_TYPE_LOGICAL
670 8 : self%logical_value = val
671 27 : end subroutine value_set_logical
672 :
673 : !> Set complex value
674 3 : subroutine value_set_complex(self, val)
675 : class(hsd_value), intent(inout) :: self
676 : complex(dp), intent(in) :: val
677 3 : self%value_type = VALUE_TYPE_COMPLEX
678 3 : self%complex_value = val
679 11 : end subroutine value_set_complex
680 :
681 : !> Set raw text (for arrays/matrices)
682 1168 : subroutine value_set_raw(self, text)
683 : class(hsd_value), intent(inout) :: self
684 : character(len=*), intent(in) :: text
685 1168 : self%value_type = VALUE_TYPE_STRING
686 1168 : self%raw_text = text
687 1168 : self%string_value = text
688 2339 : end subroutine value_set_raw
689 :
690 : !> Get string value
691 55 : subroutine value_get_string(self, val, stat)
692 : class(hsd_value), intent(in) :: self
693 : character(len=:), allocatable, intent(out) :: val
694 : integer, intent(out), optional :: stat
695 :
696 55 : if (allocated(self%string_value)) then
697 52 : val = self%string_value
698 52 : if (present(stat)) stat = HSD_STAT_OK
699 3 : else if (allocated(self%raw_text)) then
700 2 : val = self%raw_text
701 2 : if (present(stat)) stat = HSD_STAT_OK
702 : else
703 1 : val = ""
704 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
705 : end if
706 :
707 1168 : end subroutine value_get_string
708 :
709 : !> Get integer value
710 100076 : subroutine value_get_integer(self, val, stat)
711 : class(hsd_value), intent(in) :: self
712 : integer, intent(out) :: val
713 : integer, intent(out), optional :: stat
714 :
715 100076 : integer :: io_stat
716 :
717 100076 : if (self%value_type == VALUE_TYPE_INTEGER) then
718 8 : val = self%int_value
719 8 : if (present(stat)) stat = HSD_STAT_OK
720 100068 : else if (allocated(self%string_value)) then
721 100067 : read(self%string_value, *, iostat=io_stat) val
722 100067 : if (io_stat /= 0) then
723 4 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
724 : else
725 100063 : if (present(stat)) stat = HSD_STAT_OK
726 : end if
727 : else
728 1 : val = 0
729 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
730 : end if
731 :
732 55 : end subroutine value_get_integer
733 :
734 : !> Get real value
735 47 : subroutine value_get_real(self, val, stat)
736 : class(hsd_value), intent(in) :: self
737 : real(dp), intent(out) :: val
738 : integer, intent(out), optional :: stat
739 :
740 47 : integer :: io_stat
741 :
742 47 : if (self%value_type == VALUE_TYPE_REAL) then
743 5 : val = self%real_value
744 5 : if (present(stat)) stat = HSD_STAT_OK
745 42 : else if (self%value_type == VALUE_TYPE_INTEGER) then
746 1 : val = real(self%int_value, dp)
747 1 : if (present(stat)) stat = HSD_STAT_OK
748 41 : else if (allocated(self%string_value)) then
749 40 : read(self%string_value, *, iostat=io_stat) val
750 40 : if (io_stat /= 0) then
751 7 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
752 : else
753 33 : if (present(stat)) stat = HSD_STAT_OK
754 : end if
755 : else
756 1 : val = 0.0_dp
757 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
758 : end if
759 :
760 100076 : end subroutine value_get_real
761 :
762 : !> Get logical value
763 26 : subroutine value_get_logical(self, val, stat)
764 : class(hsd_value), intent(in) :: self
765 : logical, intent(out) :: val
766 : integer, intent(out), optional :: stat
767 :
768 26 : character(len=:), allocatable :: lower_val
769 :
770 26 : if (self%value_type == VALUE_TYPE_LOGICAL) then
771 3 : val = self%logical_value
772 3 : if (present(stat)) stat = HSD_STAT_OK
773 23 : else if (allocated(self%string_value)) then
774 22 : lower_val = to_lower(trim(self%string_value))
775 12 : select case (lower_val)
776 : case ("yes", "on", "1", "true", ".true.")
777 12 : val = .true.
778 12 : if (present(stat)) stat = HSD_STAT_OK
779 : case ("no", "off", "0", "false", ".false.")
780 7 : val = .false.
781 7 : if (present(stat)) stat = HSD_STAT_OK
782 : case default
783 3 : val = .false.
784 22 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
785 : end select
786 : else
787 1 : val = .false.
788 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
789 : end if
790 :
791 73 : end subroutine value_get_logical
792 :
793 : !> Get complex value
794 : !> Parses formats like: 4.0+9.0i, 2.0-3.0i, (1.0,2.0), 5.0+2.0j
795 46 : subroutine value_get_complex(self, val, stat)
796 : class(hsd_value), intent(in) :: self
797 : complex(dp), intent(out) :: val
798 : integer, intent(out), optional :: stat
799 :
800 46 : if (self%value_type == VALUE_TYPE_COMPLEX) then
801 1 : val = self%complex_value
802 1 : if (present(stat)) stat = HSD_STAT_OK
803 45 : else if (allocated(self%string_value)) then
804 44 : call parse_complex(trim(self%string_value), val, stat)
805 : else
806 1 : val = (0.0_dp, 0.0_dp)
807 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
808 : end if
809 :
810 26 : end subroutine value_get_complex
811 :
812 : !> Get integer array from raw text (parses space/comma/newline separated values)
813 : !> Caches the parsed result for subsequent calls
814 20 : subroutine value_get_int_array(self, val, stat)
815 : class(hsd_value), intent(inout) :: self
816 : integer, allocatable, intent(out) :: val(:)
817 : integer, intent(out), optional :: stat
818 :
819 20 : character(len=:), allocatable :: text
820 20 : integer :: io_stat
821 :
822 : ! If already parsed, return cached array
823 20 : if (allocated(self%int_array)) then
824 4 : val = self%int_array
825 1 : if (present(stat)) stat = HSD_STAT_OK
826 1 : return
827 : end if
828 :
829 : ! Get source text
830 19 : if (allocated(self%raw_text)) then
831 2 : text = self%raw_text
832 17 : else if (allocated(self%string_value)) then
833 15 : text = self%string_value
834 : else
835 2 : allocate(val(0))
836 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
837 2 : return
838 : end if
839 :
840 : ! Count and parse values
841 17 : call parse_int_array(text, val, io_stat)
842 17 : if (present(stat)) stat = io_stat
843 :
844 : ! Cache result for next access
845 17 : if (io_stat == 0) then
846 1577 : self%int_array = val
847 : end if
848 :
849 66 : end subroutine value_get_int_array
850 :
851 : !> Get real array from raw text
852 : !> Caches the parsed result for subsequent calls
853 19 : subroutine value_get_real_array(self, val, stat)
854 : class(hsd_value), intent(inout) :: self
855 : real(dp), allocatable, intent(out) :: val(:)
856 : integer, intent(out), optional :: stat
857 :
858 19 : character(len=:), allocatable :: text
859 19 : integer :: io_stat
860 :
861 : ! If already parsed, return cached array
862 19 : if (allocated(self%real_array)) then
863 4 : val = self%real_array
864 1 : if (present(stat)) stat = HSD_STAT_OK
865 1 : return
866 : end if
867 :
868 : ! Get source text
869 18 : if (allocated(self%raw_text)) then
870 5 : text = self%raw_text
871 13 : else if (allocated(self%string_value)) then
872 11 : text = self%string_value
873 : else
874 2 : allocate(val(0))
875 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
876 2 : return
877 : end if
878 :
879 : ! Count and parse values
880 16 : call parse_real_array(text, val, io_stat)
881 16 : if (present(stat)) stat = io_stat
882 :
883 : ! Cache result for next access
884 16 : if (io_stat == 0) then
885 60 : self%real_array = val
886 : end if
887 :
888 39 : end subroutine value_get_real_array
889 :
890 : !> Get logical array from raw text
891 : !> Caches the parsed result for subsequent calls
892 9 : subroutine value_get_logical_array(self, val, stat)
893 : class(hsd_value), intent(inout) :: self
894 : logical, allocatable, intent(out) :: val(:)
895 : integer, intent(out), optional :: stat
896 :
897 9 : character(len=:), allocatable :: text, tokens(:)
898 9 : integer :: i, n
899 9 : logical :: parse_ok
900 :
901 9 : if (allocated(self%logical_array)) then
902 3 : val = self%logical_array
903 1 : if (present(stat)) stat = HSD_STAT_OK
904 1 : return
905 : end if
906 :
907 8 : if (allocated(self%raw_text)) then
908 2 : text = self%raw_text
909 6 : else if (allocated(self%string_value)) then
910 5 : text = self%string_value
911 : else
912 1 : allocate(val(0))
913 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
914 1 : return
915 : end if
916 :
917 7 : call tokenize_string(text, tokens)
918 7 : n = size(tokens)
919 7 : allocate(val(n))
920 7 : parse_ok = .true.
921 :
922 31 : do i = 1, n
923 56 : select case (to_lower(trim(tokens(i))))
924 : case ("yes", "on", "1", "true", ".true.")
925 12 : val(i) = .true.
926 : case ("no", "off", "0", "false", ".false.")
927 12 : val(i) = .false.
928 : case default
929 1 : val(i) = .false.
930 1 : parse_ok = .false.
931 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
932 51 : return
933 : end select
934 : end do
935 :
936 6 : if (present(stat)) stat = HSD_STAT_OK
937 :
938 : ! Cache result for next access
939 6 : if (parse_ok) then
940 28 : self%logical_array = val
941 : end if
942 :
943 35 : end subroutine value_get_logical_array
944 :
945 : !> Get complex array from raw text (parses space/comma separated complex values)
946 : !> Caches the parsed result for subsequent calls
947 9 : subroutine value_get_complex_array(self, val, stat)
948 : class(hsd_value), intent(inout) :: self
949 : complex(dp), allocatable, intent(out) :: val(:)
950 : integer, intent(out), optional :: stat
951 :
952 9 : character(len=:), allocatable :: text
953 9 : integer :: io_stat
954 :
955 : ! If already parsed, return cached array
956 9 : if (allocated(self%complex_array)) then
957 3 : val = self%complex_array
958 1 : if (present(stat)) stat = HSD_STAT_OK
959 1 : return
960 : end if
961 :
962 : ! Get source text
963 8 : if (allocated(self%raw_text)) then
964 3 : text = self%raw_text
965 5 : else if (allocated(self%string_value)) then
966 4 : text = self%string_value
967 : else
968 1 : allocate(val(0))
969 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
970 1 : return
971 : end if
972 :
973 : ! Count and parse values
974 7 : call parse_complex_array(text, val, io_stat)
975 7 : if (present(stat)) stat = io_stat
976 :
977 : ! Cache result for next access
978 7 : if (io_stat == 0) then
979 19 : self%complex_array = val
980 : end if
981 :
982 18 : end subroutine value_get_complex_array
983 :
984 : !> Get string array from raw text (space-separated, quoted strings preserved)
985 : !> Caches the parsed result for subsequent calls
986 24 : subroutine value_get_string_array(self, val, stat)
987 : class(hsd_value), intent(inout) :: self
988 : character(len=:), allocatable, intent(out) :: val(:)
989 : integer, intent(out), optional :: stat
990 :
991 24 : character(len=:), allocatable :: text
992 :
993 24 : if (allocated(self%string_array)) then
994 9 : val = self%string_array
995 5 : if (present(stat)) stat = HSD_STAT_OK
996 5 : return
997 : end if
998 :
999 19 : if (allocated(self%raw_text)) then
1000 1 : text = self%raw_text
1001 18 : else if (allocated(self%string_value)) then
1002 16 : text = self%string_value
1003 : else
1004 2 : allocate(character(len=1) :: val(0))
1005 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1006 2 : return
1007 : end if
1008 :
1009 17 : call tokenize_quoted_string(text, val)
1010 17 : if (present(stat)) stat = HSD_STAT_OK
1011 :
1012 : ! Cache result for next access
1013 80 : self%string_array = val
1014 :
1015 33 : end subroutine value_get_string_array
1016 :
1017 : !> Get 2D integer matrix from raw text (rows separated by newlines or semicolons)
1018 : !> Caches the parsed result for subsequent calls
1019 16 : subroutine value_get_int_matrix(self, val, nrows, ncols, stat)
1020 : class(hsd_value), intent(inout) :: self
1021 : integer, allocatable, intent(out) :: val(:,:)
1022 : integer, intent(out) :: nrows, ncols
1023 : integer, intent(out), optional :: stat
1024 :
1025 16 : character(len=:), allocatable :: text
1026 16 : integer :: io_stat
1027 :
1028 16 : if (allocated(self%int_matrix)) then
1029 10 : val = self%int_matrix
1030 1 : nrows = self%nrows
1031 1 : ncols = self%ncols
1032 1 : if (present(stat)) stat = HSD_STAT_OK
1033 1 : return
1034 : end if
1035 :
1036 15 : if (allocated(self%raw_text)) then
1037 7 : text = self%raw_text
1038 8 : else if (allocated(self%string_value)) then
1039 7 : text = self%string_value
1040 : else
1041 1 : allocate(val(0,0))
1042 1 : nrows = 0
1043 1 : ncols = 0
1044 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1045 1 : return
1046 : end if
1047 :
1048 14 : call parse_int_matrix(text, val, nrows, ncols, io_stat)
1049 14 : if (present(stat)) stat = io_stat
1050 :
1051 : ! Cache result for next access
1052 14 : if (io_stat == 0) then
1053 126 : self%int_matrix = val
1054 10 : self%nrows = nrows
1055 10 : self%ncols = ncols
1056 : end if
1057 :
1058 16 : end subroutine value_get_int_matrix
1059 :
1060 : !> Get 2D real matrix from raw text
1061 : !> Caches the parsed result for subsequent calls
1062 14 : subroutine value_get_real_matrix(self, val, nrows, ncols, stat)
1063 : class(hsd_value), intent(inout) :: self
1064 : real(dp), allocatable, intent(out) :: val(:,:)
1065 : integer, intent(out) :: nrows, ncols
1066 : integer, intent(out), optional :: stat
1067 :
1068 14 : character(len=:), allocatable :: text
1069 14 : integer :: io_stat
1070 :
1071 14 : if (allocated(self%real_matrix)) then
1072 7 : val = self%real_matrix
1073 1 : nrows = self%nrows
1074 1 : ncols = self%ncols
1075 1 : if (present(stat)) stat = HSD_STAT_OK
1076 1 : return
1077 : end if
1078 :
1079 13 : if (allocated(self%raw_text)) then
1080 7 : text = self%raw_text
1081 6 : else if (allocated(self%string_value)) then
1082 5 : text = self%string_value
1083 : else
1084 1 : allocate(val(0,0))
1085 1 : nrows = 0
1086 1 : ncols = 0
1087 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
1088 1 : return
1089 : end if
1090 :
1091 12 : call parse_real_matrix(text, val, nrows, ncols, io_stat)
1092 12 : if (present(stat)) stat = io_stat
1093 :
1094 : ! Cache result for next access
1095 12 : if (io_stat == 0) then
1096 81 : self%real_matrix = val
1097 8 : self%nrows = nrows
1098 8 : self%ncols = ncols
1099 : end if
1100 :
1101 30 : end subroutine value_get_real_matrix
1102 :
1103 : !> Parse space/comma-separated integers from text (dynamically sized)
1104 111 : subroutine parse_int_array(text, arr, stat)
1105 : character(len=*), intent(in) :: text
1106 : integer, allocatable, intent(out) :: arr(:)
1107 : integer, intent(out) :: stat
1108 :
1109 33 : character(len=:), allocatable :: tokens(:)
1110 33 : integer :: i, n, val, io_stat
1111 :
1112 0 : call tokenize_string(text, tokens)
1113 33 : n = size(tokens)
1114 :
1115 33 : allocate(arr(n))
1116 1657 : do i = 1, n
1117 1630 : read(tokens(i), *, iostat=io_stat) val
1118 1630 : if (io_stat /= 0) then
1119 6 : deallocate(arr)
1120 6 : allocate(arr(0))
1121 6 : stat = io_stat
1122 6 : return
1123 : end if
1124 1651 : arr(i) = val
1125 : end do
1126 :
1127 27 : stat = 0
1128 :
1129 80 : end subroutine parse_int_array
1130 :
1131 : !> Parse space/comma-separated reals from text (dynamically sized)
1132 28 : subroutine parse_real_array(text, arr, stat)
1133 : character(len=*), intent(in) :: text
1134 : real(dp), allocatable, intent(out) :: arr(:)
1135 : integer, intent(out) :: stat
1136 :
1137 28 : character(len=:), allocatable :: tokens(:)
1138 28 : integer :: i, n, io_stat
1139 28 : real(dp) :: val
1140 :
1141 0 : call tokenize_string(text, tokens)
1142 28 : n = size(tokens)
1143 :
1144 28 : allocate(arr(n))
1145 114 : do i = 1, n
1146 93 : read(tokens(i), *, iostat=io_stat) val
1147 93 : if (io_stat /= 0) then
1148 7 : deallocate(arr)
1149 7 : allocate(arr(0))
1150 7 : stat = io_stat
1151 7 : return
1152 : end if
1153 107 : arr(i) = val
1154 : end do
1155 :
1156 21 : stat = 0
1157 :
1158 89 : end subroutine parse_real_array
1159 :
1160 : !> Tokenize string by whitespace and commas
1161 105 : subroutine tokenize_string(text, tokens)
1162 : character(len=*), intent(in) :: text
1163 : character(len=:), allocatable, intent(out) :: tokens(:)
1164 :
1165 105 : integer :: i, start, max_len, token_count
1166 0 : character(len=len(text)) :: temp_tokens(len(text))
1167 105 : logical :: in_token
1168 :
1169 : ! First pass: count tokens and find max length
1170 105 : token_count = 0
1171 105 : max_len = 0
1172 105 : in_token = .false.
1173 105 : start = 1
1174 :
1175 8148 : do i = 1, len(text)
1176 8148 : if (is_separator(text(i:i))) then
1177 1832 : if (in_token) then
1178 1809 : token_count = token_count + 1
1179 1809 : max_len = max(max_len, i - start)
1180 1809 : temp_tokens(token_count) = text(start:i-1)
1181 1809 : in_token = .false.
1182 : end if
1183 : else
1184 6211 : if (.not. in_token) then
1185 1906 : start = i
1186 1906 : in_token = .true.
1187 : end if
1188 : end if
1189 : end do
1190 :
1191 : ! Handle last token
1192 105 : if (in_token) then
1193 97 : token_count = token_count + 1
1194 97 : max_len = max(max_len, len(text) - start + 1)
1195 97 : temp_tokens(token_count) = text(start:len(text))
1196 : end if
1197 :
1198 : ! Allocate and copy
1199 105 : if (token_count > 0 .and. max_len > 0) then
1200 104 : allocate(character(len=max_len) :: tokens(token_count))
1201 2010 : do i = 1, token_count
1202 2010 : tokens(i) = trim(temp_tokens(i))
1203 : end do
1204 : else
1205 1 : allocate(character(len=1) :: tokens(0))
1206 : end if
1207 :
1208 28 : end subroutine tokenize_string
1209 :
1210 : !> Check if character is a separator (whitespace, comma, semicolon)
1211 8153 : pure function is_separator(ch) result(is_sep)
1212 : character(len=1), intent(in) :: ch
1213 : logical :: is_sep
1214 : is_sep = (ch == ' ' .or. ch == char(9) .or. ch == char(10) .or. &
1215 8153 : ch == char(13) .or. ch == ',' .or. ch == ';')
1216 8258 : end function is_separator
1217 :
1218 : !> Tokenize string preserving quoted sections
1219 17 : subroutine tokenize_quoted_string(text, tokens)
1220 : character(len=*), intent(in) :: text
1221 : character(len=:), allocatable, intent(out) :: tokens(:)
1222 :
1223 17 : integer :: i, start, max_len, token_count, tlen
1224 0 : character(len=len(text)) :: temp_tokens(len(text))
1225 : character(len=1) :: quote_char
1226 17 : logical :: in_token, in_quote
1227 :
1228 17 : token_count = 0
1229 17 : max_len = 0
1230 17 : in_token = .false.
1231 17 : in_quote = .false.
1232 17 : quote_char = ' '
1233 17 : start = 1
1234 17 : tlen = len_trim(text)
1235 :
1236 17 : i = 1
1237 143 : do while (i <= tlen)
1238 126 : if (in_quote) then
1239 : ! Look for closing quote
1240 13 : if (text(i:i) == quote_char) then
1241 3 : token_count = token_count + 1
1242 3 : max_len = max(max_len, i - start - 1)
1243 3 : if (i > start + 1) then
1244 2 : temp_tokens(token_count) = text(start+1:i-1)
1245 : else
1246 1 : temp_tokens(token_count) = ""
1247 : end if
1248 3 : in_quote = .false.
1249 3 : in_token = .false.
1250 : end if
1251 113 : else if (text(i:i) == '"' .or. text(i:i) == "'") then
1252 3 : quote_char = text(i:i)
1253 3 : in_quote = .true.
1254 3 : start = i
1255 3 : in_token = .true.
1256 110 : else if (is_separator(text(i:i))) then
1257 17 : if (in_token) then
1258 16 : token_count = token_count + 1
1259 16 : max_len = max(max_len, i - start)
1260 16 : temp_tokens(token_count) = text(start:i-1)
1261 16 : in_token = .false.
1262 : end if
1263 : else
1264 93 : if (.not. in_token) then
1265 27 : start = i
1266 27 : in_token = .true.
1267 : end if
1268 : end if
1269 126 : i = i + 1
1270 : end do
1271 :
1272 : ! Handle last token
1273 17 : if (in_token .and. .not. in_quote) then
1274 11 : token_count = token_count + 1
1275 11 : max_len = max(max_len, tlen - start + 1)
1276 11 : temp_tokens(token_count) = text(start:tlen)
1277 : end if
1278 :
1279 : ! Allocate and copy
1280 17 : if (token_count > 0 .and. max_len > 0) then
1281 12 : allocate(character(len=max_len) :: tokens(token_count))
1282 41 : do i = 1, token_count
1283 41 : tokens(i) = trim(temp_tokens(i))
1284 : end do
1285 : else
1286 5 : allocate(character(len=1) :: tokens(0))
1287 : end if
1288 :
1289 8153 : end subroutine tokenize_quoted_string
1290 :
1291 : !> Parse 2D integer matrix (rows separated by newlines or semicolons)
1292 14 : subroutine parse_int_matrix(text, mat, nrows, ncols, stat)
1293 : character(len=*), intent(in) :: text
1294 : integer, allocatable, intent(out) :: mat(:,:)
1295 : integer, intent(out) :: nrows, ncols, stat
1296 :
1297 14 : character(len=:), allocatable :: rows(:), tokens(:)
1298 14 : integer, allocatable :: row_vals(:)
1299 14 : integer :: i, j, row_count, col_count, first_cols
1300 :
1301 : ! Split into rows by newlines
1302 0 : call split_by_newlines(text, rows)
1303 14 : row_count = size(rows)
1304 :
1305 : ! Count non-empty rows and determine column count
1306 14 : nrows = 0
1307 14 : ncols = 0
1308 14 : first_cols = -1
1309 :
1310 33 : do i = 1, row_count
1311 33 : if (len_trim(rows(i)) > 0) then
1312 17 : call tokenize_string(rows(i), tokens)
1313 17 : col_count = size(tokens)
1314 17 : if (col_count > 0) then
1315 17 : nrows = nrows + 1
1316 17 : if (first_cols < 0) then
1317 13 : first_cols = col_count
1318 13 : ncols = col_count
1319 4 : else if (col_count /= first_cols) then
1320 : ! Inconsistent column count - use max
1321 2 : ncols = max(ncols, col_count)
1322 : end if
1323 : end if
1324 : end if
1325 : end do
1326 :
1327 14 : if (nrows == 0 .or. ncols == 0) then
1328 1 : allocate(mat(0,0))
1329 1 : nrows = 0
1330 1 : ncols = 0
1331 1 : stat = 0
1332 1 : return
1333 : end if
1334 :
1335 13 : allocate(mat(nrows, ncols))
1336 152 : mat = 0
1337 :
1338 13 : j = 0
1339 26 : do i = 1, row_count
1340 26 : if (len_trim(rows(i)) > 0) then
1341 16 : call parse_int_array(rows(i), row_vals, stat)
1342 16 : if (stat /= 0) then
1343 4 : deallocate(mat)
1344 4 : allocate(mat(0,0))
1345 4 : nrows = 0
1346 4 : ncols = 0
1347 4 : return
1348 : end if
1349 12 : if (size(row_vals) > 0) then
1350 12 : j = j + 1
1351 72 : mat(j, 1:min(size(row_vals), ncols)) = row_vals(1:min(size(row_vals), ncols))
1352 : end if
1353 : end if
1354 : end do
1355 :
1356 9 : stat = 0
1357 :
1358 45 : end subroutine parse_int_matrix
1359 :
1360 : !> Parse 2D real matrix
1361 12 : subroutine parse_real_matrix(text, mat, nrows, ncols, stat)
1362 : character(len=*), intent(in) :: text
1363 : real(dp), allocatable, intent(out) :: mat(:,:)
1364 : integer, intent(out) :: nrows, ncols, stat
1365 :
1366 12 : character(len=:), allocatable :: rows(:), tokens(:)
1367 12 : real(dp), allocatable :: row_vals(:)
1368 12 : integer :: i, j, row_count, col_count, first_cols
1369 :
1370 0 : call split_by_newlines(text, rows)
1371 12 : row_count = size(rows)
1372 :
1373 12 : nrows = 0
1374 12 : ncols = 0
1375 12 : first_cols = -1
1376 :
1377 26 : do i = 1, row_count
1378 26 : if (len_trim(rows(i)) > 0) then
1379 13 : call tokenize_string(rows(i), tokens)
1380 13 : col_count = size(tokens)
1381 13 : if (col_count > 0) then
1382 13 : nrows = nrows + 1
1383 13 : if (first_cols < 0) then
1384 11 : first_cols = col_count
1385 11 : ncols = col_count
1386 2 : else if (col_count /= first_cols) then
1387 1 : ncols = max(ncols, col_count)
1388 : end if
1389 : end if
1390 : end if
1391 : end do
1392 :
1393 12 : if (nrows == 0 .or. ncols == 0) then
1394 1 : allocate(mat(0,0))
1395 1 : nrows = 0
1396 1 : ncols = 0
1397 1 : stat = 0
1398 1 : return
1399 : end if
1400 :
1401 11 : allocate(mat(nrows, ncols))
1402 109 : mat = 0.0_dp
1403 :
1404 11 : j = 0
1405 19 : do i = 1, row_count
1406 19 : if (len_trim(rows(i)) > 0) then
1407 12 : call parse_real_array(rows(i), row_vals, stat)
1408 12 : if (stat /= 0) then
1409 4 : deallocate(mat)
1410 4 : allocate(mat(0,0))
1411 4 : nrows = 0
1412 4 : ncols = 0
1413 4 : return
1414 : end if
1415 8 : if (size(row_vals) > 0) then
1416 8 : j = j + 1
1417 45 : mat(j, 1:min(size(row_vals), ncols)) = row_vals(1:min(size(row_vals), ncols))
1418 : end if
1419 : end if
1420 : end do
1421 :
1422 7 : stat = 0
1423 :
1424 38 : end subroutine parse_real_matrix
1425 :
1426 : !> Split text by newlines
1427 26 : subroutine split_by_newlines(text, lines)
1428 : character(len=*), intent(in) :: text
1429 : character(len=:), allocatable, intent(out) :: lines(:)
1430 :
1431 26 : integer :: i, start, line_count, max_len, tlen
1432 0 : character(len=len(text)) :: temp_lines(len(text))
1433 :
1434 26 : line_count = 0
1435 26 : max_len = 0
1436 26 : start = 1
1437 26 : tlen = len(text)
1438 :
1439 381 : do i = 1, tlen
1440 381 : if (text(i:i) == char(10) .or. text(i:i) == ';') then
1441 7 : line_count = line_count + 1
1442 7 : max_len = max(max_len, i - start)
1443 7 : if (i > start) then
1444 6 : temp_lines(line_count) = text(start:i-1)
1445 : else
1446 1 : temp_lines(line_count) = ""
1447 : end if
1448 7 : start = i + 1
1449 : end if
1450 : end do
1451 :
1452 : ! Handle last line
1453 26 : if (start <= tlen) then
1454 25 : line_count = line_count + 1
1455 25 : max_len = max(max_len, tlen - start + 1)
1456 25 : temp_lines(line_count) = text(start:tlen)
1457 : end if
1458 :
1459 26 : if (line_count > 0 .and. max_len > 0) then
1460 25 : allocate(character(len=max_len) :: lines(line_count))
1461 57 : do i = 1, line_count
1462 57 : lines(i) = trim(temp_lines(i))
1463 : end do
1464 : else
1465 1 : allocate(character(len=1) :: lines(1))
1466 1 : lines(1) = text
1467 : end if
1468 :
1469 12 : end subroutine split_by_newlines
1470 :
1471 : !> Destroy value
1472 494543 : subroutine value_destroy(self)
1473 : class(hsd_value), intent(inout) :: self
1474 :
1475 494506 : if (allocated(self%name)) deallocate(self%name)
1476 494543 : if (allocated(self%attrib)) deallocate(self%attrib)
1477 494543 : if (allocated(self%string_value)) deallocate(self%string_value)
1478 494543 : if (allocated(self%raw_text)) deallocate(self%raw_text)
1479 494543 : if (allocated(self%int_array)) deallocate(self%int_array)
1480 494543 : if (allocated(self%real_array)) deallocate(self%real_array)
1481 494543 : if (allocated(self%logical_array)) deallocate(self%logical_array)
1482 494543 : if (allocated(self%string_array)) deallocate(self%string_array)
1483 494543 : if (allocated(self%complex_array)) deallocate(self%complex_array)
1484 494543 : if (allocated(self%int_matrix)) deallocate(self%int_matrix)
1485 494543 : if (allocated(self%real_matrix)) deallocate(self%real_matrix)
1486 :
1487 494543 : self%value_type = VALUE_TYPE_NONE
1488 494543 : self%nrows = 0
1489 494543 : self%ncols = 0
1490 :
1491 26 : end subroutine value_destroy
1492 :
1493 : !> Parse a single complex number from string
1494 : !> Supports formats: 4.0+9.0i, 2.0-3.0i, (1.0,2.0), 5.0+2.0j, 3.5, pure imaginary 2.0i
1495 61 : subroutine parse_complex(str, val, stat)
1496 : character(len=*), intent(in) :: str
1497 : complex(dp), intent(out) :: val
1498 : integer, intent(out), optional :: stat
1499 :
1500 61 : character(len=:), allocatable :: work
1501 61 : integer :: i, sign_pos, io_stat
1502 61 : real(dp) :: re, im
1503 : character(len=1) :: ch
1504 :
1505 61 : work = adjustl(trim(str))
1506 :
1507 : ! Handle empty string
1508 61 : if (len_trim(work) == 0) then
1509 1 : val = (0.0_dp, 0.0_dp)
1510 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
1511 1 : return
1512 : end if
1513 :
1514 : ! Handle Fortran-style (re,im) format
1515 60 : if (work(1:1) == '(') then
1516 7 : i = index(work, ')')
1517 7 : if (i > 2) then
1518 6 : work = work(2:i-1)
1519 6 : i = index(work, ',')
1520 6 : if (i > 0) then
1521 6 : read(work(1:i-1), *, iostat=io_stat) re
1522 6 : if (io_stat /= 0) then
1523 3 : val = (0.0_dp, 0.0_dp)
1524 3 : if (present(stat)) stat = io_stat
1525 3 : return
1526 : end if
1527 3 : read(work(i+1:), *, iostat=io_stat) im
1528 3 : if (io_stat /= 0) then
1529 1 : val = (0.0_dp, 0.0_dp)
1530 1 : if (present(stat)) stat = io_stat
1531 1 : return
1532 : end if
1533 2 : val = cmplx(re, im, dp)
1534 2 : if (present(stat)) stat = HSD_STAT_OK
1535 2 : return
1536 : end if
1537 : end if
1538 : end if
1539 :
1540 : ! Handle a+bi or a-bi format (also handles j instead of i)
1541 : ! Find the + or - that separates real and imaginary parts
1542 : ! (must skip the first char and any exponent signs)
1543 54 : sign_pos = 0
1544 545 : do i = 2, len_trim(work)
1545 491 : ch = work(i:i)
1546 545 : if ((ch == '+' .or. ch == '-')) then
1547 : ! Make sure this isn't part of an exponent
1548 39 : if (i > 1) then
1549 : if (work(i-1:i-1) /= 'e' .and. work(i-1:i-1) /= 'E' .and. &
1550 39 : work(i-1:i-1) /= 'd' .and. work(i-1:i-1) /= 'D') then
1551 39 : sign_pos = i
1552 : end if
1553 : end if
1554 : end if
1555 : end do
1556 :
1557 : ! Check if last character is 'i' or 'j' (imaginary marker)
1558 54 : ch = work(len_trim(work):len_trim(work))
1559 54 : if (ch == 'i' .or. ch == 'I' .or. ch == 'j' .or. ch == 'J') then
1560 47 : if (sign_pos > 0) then
1561 : ! Format: a+bi or a-bi
1562 38 : read(work(1:sign_pos-1), *, iostat=io_stat) re
1563 38 : if (io_stat /= 0) then
1564 2 : val = (0.0_dp, 0.0_dp)
1565 2 : if (present(stat)) stat = io_stat
1566 2 : return
1567 : end if
1568 36 : read(work(sign_pos:len_trim(work)-1), *, iostat=io_stat) im
1569 36 : if (io_stat /= 0) then
1570 2 : val = (0.0_dp, 0.0_dp)
1571 2 : if (present(stat)) stat = io_stat
1572 2 : return
1573 : end if
1574 34 : val = cmplx(re, im, dp)
1575 34 : if (present(stat)) stat = HSD_STAT_OK
1576 34 : return
1577 : else
1578 : ! Pure imaginary: bi
1579 9 : read(work(1:len_trim(work)-1), *, iostat=io_stat) im
1580 9 : if (io_stat /= 0) then
1581 0 : val = (0.0_dp, 0.0_dp)
1582 0 : if (present(stat)) stat = io_stat
1583 0 : return
1584 : end if
1585 9 : val = cmplx(0.0_dp, im, dp)
1586 9 : if (present(stat)) stat = HSD_STAT_OK
1587 9 : return
1588 : end if
1589 : else
1590 : ! Pure real number
1591 7 : read(work, *, iostat=io_stat) re
1592 7 : if (io_stat /= 0) then
1593 4 : val = (0.0_dp, 0.0_dp)
1594 4 : if (present(stat)) stat = io_stat
1595 4 : return
1596 : end if
1597 3 : val = cmplx(re, 0.0_dp, dp)
1598 3 : if (present(stat)) stat = HSD_STAT_OK
1599 : end if
1600 :
1601 494604 : end subroutine parse_complex
1602 :
1603 : !> Parse an array of complex numbers from text
1604 7 : subroutine parse_complex_array(text, arr, stat)
1605 : character(len=*), intent(in) :: text
1606 : complex(dp), allocatable, intent(out) :: arr(:)
1607 : integer, intent(out) :: stat
1608 :
1609 7 : character(len=:), allocatable :: tokens(:)
1610 7 : integer :: i, n, io_stat
1611 7 : complex(dp) :: val
1612 :
1613 0 : call tokenize_string(text, tokens)
1614 7 : n = size(tokens)
1615 :
1616 7 : allocate(arr(n))
1617 22 : do i = 1, n
1618 17 : call parse_complex(tokens(i), val, io_stat)
1619 17 : if (io_stat /= 0) then
1620 2 : deallocate(arr)
1621 2 : allocate(arr(0))
1622 2 : stat = io_stat
1623 2 : return
1624 : end if
1625 37 : arr(i) = val
1626 : end do
1627 :
1628 5 : stat = 0
1629 :
1630 75 : end subroutine parse_complex_array
1631 :
1632 17395784 : end module hsd_types
|
