Line data Source code
1 : !> HSD Access Object
2 : !>
3 : !> Provides a configurable, error-accumulating interface for reading and writing
4 : !> HSD tree values. This is the primary user-facing API for the HSD library.
5 : !>
6 : !> ## Usage
7 : !>
8 : !> ```fortran
9 : !> type(hsd_node_t), target :: root
10 : !> type(hsd_access_t) :: access
11 : !>
12 : !> call hsd_load_file("input.hsd", root, error)
13 : !> call access%init(root)
14 : !> call access%get("Geometry/Periodic", periodic, default=.false.)
15 : !> call access%get("Hamiltonian/MaxIter", max_iter, default=100)
16 : !> if (access%has_errors()) then
17 : !> call access%print_errors()
18 : !> stop 1
19 : !> end if
20 : !> ```
21 : !>
22 : !> ## On-Missing Behavior
23 : !>
24 : !> When a key is not found and a default is provided, the `on_missing` setting
25 : !> controls what happens:
26 : !>
27 : !> - `HSD_ON_MISSING_SET` (default): writes the default value back to the tree,
28 : !> critical for generating processed output (e.g. dftb_pin.hsd).
29 : !> - `HSD_ON_MISSING_RETURN`: returns the default without modifying the tree.
30 : !>
31 : !> ## Thread Safety
32 : !>
33 : !> The access object is NOT thread-safe. Each thread should use its own instance.
34 : !> The root node must have the `target` attribute and must outlive the access object.
35 : module hsd_access
36 : use, intrinsic :: iso_fortran_env, only: error_unit
37 2 : use hsd_constants, only: dp
38 : use hsd_utils, only: to_lower
39 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_NOT_FOUND, HSD_STAT_TYPE_ERROR
40 : use hsd_types, only: hsd_node_t, NODE_TYPE_TABLE, NODE_TYPE_VALUE
41 : use hsd_api, only: hsd_get_child, hsd_set, hsd_get_matrix
42 : implicit none (type, external)
43 : private
44 :
45 : !> Write default value back to tree when key is missing
46 : integer, parameter, public :: HSD_ON_MISSING_SET = 1
47 : !> Return default without modifying the tree
48 : integer, parameter, public :: HSD_ON_MISSING_RETURN = 2
49 :
50 : !> Single error entry in the error stack
51 : type, public :: hsd_error_entry_t
52 : character(len=:), allocatable :: path
53 : integer :: stat = 0
54 : character(len=:), allocatable :: message
55 : end type hsd_error_entry_t
56 :
57 : !> Configurable access object for HSD trees
58 : !>
59 : !> Wraps an HSD tree root with configurable behavior (processed marking,
60 : !> default handling) and accumulates errors for batch checking.
61 : type, public :: hsd_access_t
62 : !> Non-owning pointer to tree root (must have target attribute)
63 : type(hsd_node_t), pointer :: root => null()
64 : !> Whether to set the processed flag on accessed nodes
65 : logical :: mark_processed = .true.
66 : !> Behavior when a key is not found and a default is provided
67 : integer :: on_missing = HSD_ON_MISSING_SET
68 : !> Error stack (grows by doubling)
69 : type(hsd_error_entry_t), allocatable :: errors(:)
70 : !> Number of errors currently in the stack
71 : integer :: num_errors = 0
72 : contains
73 : procedure :: init => access_init
74 : ! Scalar getters
75 : procedure, private :: get_string => access_get_string
76 : procedure, private :: get_integer => access_get_integer
77 : procedure, private :: get_real_dp => access_get_real_dp
78 : procedure, private :: get_logical => access_get_logical
79 : procedure, private :: get_complex_dp => access_get_complex_dp
80 : ! Array getters
81 : procedure, private :: get_integer_array => access_get_integer_array
82 : procedure, private :: get_real_dp_array => access_get_real_dp_array
83 : procedure, private :: get_logical_array => access_get_logical_array
84 : procedure, private :: get_string_array => access_get_string_array
85 : procedure, private :: get_complex_dp_array => access_get_complex_dp_array
86 : !> Generic value getter (resolves on val type and rank)
87 : generic :: get => get_string, get_integer, get_real_dp, get_logical, &
88 : & get_complex_dp, get_integer_array, get_real_dp_array, &
89 : & get_logical_array, get_string_array, get_complex_dp_array
90 : ! Matrix getters
91 : procedure, private :: get_int_matrix => access_get_int_matrix
92 : procedure, private :: get_real_matrix => access_get_real_matrix
93 : procedure, private :: get_complex_matrix => access_get_complex_matrix
94 : !> Generic matrix getter (resolves on val element type)
95 : generic :: get_matrix => get_int_matrix, get_real_matrix, get_complex_matrix
96 : ! Scalar setters
97 : procedure, private :: set_string => access_set_string
98 : procedure, private :: set_integer => access_set_integer
99 : procedure, private :: set_real_dp => access_set_real_dp
100 : procedure, private :: set_logical => access_set_logical
101 : procedure, private :: set_complex_dp => access_set_complex_dp
102 : ! Array setters
103 : procedure, private :: set_integer_array => access_set_integer_array
104 : procedure, private :: set_real_dp_array => access_set_real_dp_array
105 : procedure, private :: set_logical_array => access_set_logical_array
106 : procedure, private :: set_string_array => access_set_string_array
107 : procedure, private :: set_complex_dp_array => access_set_complex_dp_array
108 : ! Matrix setters
109 : procedure, private :: set_integer_matrix => access_set_integer_matrix
110 : procedure, private :: set_real_dp_matrix => access_set_real_dp_matrix
111 : procedure, private :: set_complex_dp_matrix => access_set_complex_dp_matrix
112 : !> Generic value/array/matrix setter (resolves on val type and rank)
113 : generic :: set => set_string, set_integer, set_real_dp, set_logical, &
114 : & set_complex_dp, set_integer_array, set_real_dp_array, &
115 : & set_logical_array, set_string_array, set_complex_dp_array, &
116 : & set_integer_matrix, set_real_dp_matrix, set_complex_dp_matrix
117 : ! Choice getter
118 : procedure :: get_choice => access_get_choice
119 : ! Error handling
120 : procedure :: has_errors => access_has_errors
121 : procedure :: error_count => access_error_count
122 : procedure :: print_errors => access_print_errors
123 : procedure :: clear_errors => access_clear_errors
124 : procedure :: get_errors => access_get_errors
125 : ! Internal helpers
126 : procedure, private :: push_error => access_push_error
127 : procedure, private :: resolve_value_node => access_resolve_value_node
128 : procedure, private :: mark_path_processed => access_mark_path_processed
129 : end type hsd_access_t
130 :
131 : contains
132 :
133 : ! ===== Initialization =====
134 :
135 : !> Initialize the access object with a tree root
136 78 : subroutine access_init(self, root, mark_processed, on_missing)
137 : class(hsd_access_t), intent(out) :: self
138 : type(hsd_node_t), intent(in), target :: root
139 : logical, intent(in), optional :: mark_processed
140 : integer, intent(in), optional :: on_missing
141 :
142 39 : self%root => root
143 39 : if (present(mark_processed)) self%mark_processed = mark_processed
144 39 : if (present(on_missing)) self%on_missing = on_missing
145 663 : allocate(self%errors(16))
146 39 : self%num_errors = 0
147 39 : end subroutine access_init
148 :
149 : ! ===== Error Stack =====
150 :
151 : !> Push an error entry onto the stack
152 9 : subroutine access_push_error(self, path, stat, message)
153 : class(hsd_access_t), intent(inout) :: self
154 : character(len=*), intent(in) :: path
155 : integer, intent(in) :: stat
156 : character(len=*), intent(in) :: message
157 :
158 9 : type(hsd_error_entry_t), allocatable :: tmp(:)
159 :
160 0 : if (.not. allocated(self%errors)) allocate(self%errors(16))
161 :
162 9 : if (self%num_errors >= size(self%errors)) then
163 0 : allocate(tmp(size(self%errors) * 2))
164 0 : tmp(1:self%num_errors) = self%errors(1:self%num_errors)
165 0 : call move_alloc(tmp, self%errors)
166 : end if
167 :
168 9 : self%num_errors = self%num_errors + 1
169 9 : self%errors(self%num_errors)%path = path
170 9 : self%errors(self%num_errors)%stat = stat
171 9 : self%errors(self%num_errors)%message = message
172 48 : end subroutine access_push_error
173 :
174 : !> Check whether any errors have been accumulated
175 32 : pure function access_has_errors(self) result(has)
176 : class(hsd_access_t), intent(in) :: self
177 : logical :: has
178 32 : has = self%num_errors > 0
179 9 : end function access_has_errors
180 :
181 : !> Return the number of accumulated errors
182 3 : pure function access_error_count(self) result(n)
183 : class(hsd_access_t), intent(in) :: self
184 : integer :: n
185 3 : n = self%num_errors
186 32 : end function access_error_count
187 :
188 : !> Print all accumulated errors to a file unit (default: stderr)
189 1 : subroutine access_print_errors(self, unit)
190 : class(hsd_access_t), intent(in) :: self
191 : integer, intent(in), optional :: unit
192 :
193 1 : integer :: iu, ii
194 :
195 1 : iu = error_unit
196 1 : if (present(unit)) iu = unit
197 :
198 2 : do ii = 1, self%num_errors
199 : write(iu, '(A,A,A,A)') &
200 1 : & "Error at '", self%errors(ii)%path, &
201 3 : & "': ", self%errors(ii)%message
202 : end do
203 3 : end subroutine access_print_errors
204 :
205 : !> Clear all accumulated errors
206 1 : subroutine access_clear_errors(self)
207 : class(hsd_access_t), intent(inout) :: self
208 1 : self%num_errors = 0
209 1 : end subroutine access_clear_errors
210 :
211 : !> Return a copy of all accumulated errors
212 1 : subroutine access_get_errors(self, errors)
213 : class(hsd_access_t), intent(in) :: self
214 : type(hsd_error_entry_t), allocatable, intent(out) :: errors(:)
215 :
216 1 : if (self%num_errors > 0) then
217 4 : errors = self%errors(1:self%num_errors)
218 : else
219 0 : allocate(errors(0))
220 : end if
221 2 : end subroutine access_get_errors
222 :
223 : ! ===== Internal Helpers =====
224 :
225 : !> Resolve a path to a value node, handling inline text transparently
226 35 : subroutine access_resolve_value_node(self, path, val_node, stat)
227 : class(hsd_access_t), intent(inout) :: self
228 : character(len=*), intent(in) :: path
229 : type(hsd_node_t), pointer, intent(out) :: val_node
230 : integer, intent(out) :: stat
231 :
232 : type(hsd_node_t), pointer :: child
233 :
234 35 : nullify(val_node)
235 35 : call hsd_get_child(self%root, path, child, stat)
236 35 : if (stat /= HSD_STAT_OK .or. .not. associated(child)) then
237 14 : stat = HSD_STAT_NOT_FOUND
238 14 : return
239 : end if
240 :
241 21 : if (self%mark_processed) child%processed = .true.
242 :
243 21 : if (child%node_type == NODE_TYPE_VALUE) then
244 21 : val_node => child
245 21 : stat = HSD_STAT_OK
246 0 : else if (child%node_type == NODE_TYPE_TABLE) then
247 : ! Try to extract inline value (#text child)
248 0 : call child%get_child_by_name("#text", val_node)
249 0 : if (associated(val_node) .and. &
250 : & val_node%node_type == NODE_TYPE_VALUE) then
251 0 : stat = HSD_STAT_OK
252 : else
253 0 : nullify(val_node)
254 0 : stat = HSD_STAT_TYPE_ERROR
255 : end if
256 : else
257 0 : stat = HSD_STAT_TYPE_ERROR
258 : end if
259 36 : end subroutine access_resolve_value_node
260 :
261 : !> Mark the child at the given path as processed
262 6 : subroutine access_mark_path_processed(self, path)
263 : class(hsd_access_t), intent(inout) :: self
264 : character(len=*), intent(in) :: path
265 :
266 : type(hsd_node_t), pointer :: child
267 6 : integer :: local_stat
268 :
269 0 : if (.not. self%mark_processed) return
270 6 : call hsd_get_child(self%root, path, child, local_stat)
271 6 : if (local_stat == HSD_STAT_OK .and. associated(child)) &
272 6 : & child%processed = .true.
273 41 : end subroutine access_mark_path_processed
274 :
275 : ! ===== Scalar Getters =====
276 :
277 : !> Get string value by path
278 4 : subroutine access_get_string(self, path, val, default)
279 : class(hsd_access_t), intent(inout) :: self
280 : character(len=*), intent(in) :: path
281 : character(len=:), allocatable, intent(out) :: val
282 : character(len=*), intent(in), optional :: default
283 :
284 : type(hsd_node_t), pointer :: vnode
285 4 : integer :: local_stat
286 :
287 4 : call self%resolve_value_node(path, vnode, local_stat)
288 4 : if (local_stat == HSD_STAT_OK) then
289 2 : call vnode%get_string(val, local_stat)
290 2 : if (local_stat /= HSD_STAT_OK) then
291 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
292 0 : & "Cannot read as string")
293 0 : val = ""
294 : end if
295 2 : return
296 : end if
297 :
298 2 : if (present(default)) then
299 1 : val = default
300 1 : if (self%on_missing == HSD_ON_MISSING_SET) then
301 1 : call hsd_set(self%root, path, default)
302 1 : call self%mark_path_processed(path)
303 : end if
304 : else
305 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
306 1 : & "Required string field not found")
307 1 : val = ""
308 : end if
309 10 : end subroutine access_get_string
310 :
311 : !> Get integer value by path
312 15 : subroutine access_get_integer(self, path, val, default)
313 : class(hsd_access_t), intent(inout) :: self
314 : character(len=*), intent(in) :: path
315 : integer, intent(out) :: val
316 : integer, intent(in), optional :: default
317 :
318 : type(hsd_node_t), pointer :: vnode
319 15 : integer :: local_stat
320 :
321 15 : call self%resolve_value_node(path, vnode, local_stat)
322 15 : if (local_stat == HSD_STAT_OK) then
323 7 : call vnode%get_integer(val, local_stat)
324 7 : if (local_stat /= HSD_STAT_OK) then
325 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
326 1 : & "Cannot parse as integer")
327 1 : val = 0
328 : end if
329 7 : return
330 : end if
331 :
332 8 : if (present(default)) then
333 3 : val = default
334 3 : if (self%on_missing == HSD_ON_MISSING_SET) then
335 2 : call hsd_set(self%root, path, default)
336 2 : call self%mark_path_processed(path)
337 : end if
338 : else
339 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
340 5 : & "Required integer field not found")
341 5 : val = 0
342 : end if
343 19 : end subroutine access_get_integer
344 :
345 : !> Get double precision real value by path
346 4 : subroutine access_get_real_dp(self, path, val, default)
347 : class(hsd_access_t), intent(inout) :: self
348 : character(len=*), intent(in) :: path
349 : real(dp), intent(out) :: val
350 : real(dp), intent(in), optional :: default
351 :
352 : type(hsd_node_t), pointer :: vnode
353 4 : integer :: local_stat
354 :
355 4 : call self%resolve_value_node(path, vnode, local_stat)
356 4 : if (local_stat == HSD_STAT_OK) then
357 2 : call vnode%get_real(val, local_stat)
358 2 : if (local_stat /= HSD_STAT_OK) then
359 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
360 0 : & "Cannot parse as real")
361 0 : val = 0.0_dp
362 : end if
363 2 : return
364 : end if
365 :
366 2 : if (present(default)) then
367 1 : val = default
368 1 : if (self%on_missing == HSD_ON_MISSING_SET) then
369 1 : call hsd_set(self%root, path, default)
370 1 : call self%mark_path_processed(path)
371 : end if
372 : else
373 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
374 1 : & "Required real field not found")
375 1 : val = 0.0_dp
376 : end if
377 19 : end subroutine access_get_real_dp
378 :
379 : !> Get logical value by path
380 3 : subroutine access_get_logical(self, path, val, default)
381 : class(hsd_access_t), intent(inout) :: self
382 : character(len=*), intent(in) :: path
383 : logical, intent(out) :: val
384 : logical, intent(in), optional :: default
385 :
386 : type(hsd_node_t), pointer :: vnode
387 3 : integer :: local_stat
388 :
389 3 : call self%resolve_value_node(path, vnode, local_stat)
390 3 : if (local_stat == HSD_STAT_OK) then
391 2 : call vnode%get_logical(val, local_stat)
392 2 : if (local_stat /= HSD_STAT_OK) then
393 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
394 0 : & "Cannot parse as logical")
395 0 : val = .false.
396 : end if
397 2 : return
398 : end if
399 :
400 1 : if (present(default)) then
401 1 : val = default
402 1 : if (self%on_missing == HSD_ON_MISSING_SET) then
403 1 : call hsd_set(self%root, path, default)
404 1 : call self%mark_path_processed(path)
405 : end if
406 : else
407 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
408 0 : & "Required logical field not found")
409 0 : val = .false.
410 : end if
411 7 : end subroutine access_get_logical
412 :
413 : !> Get complex double precision value by path
414 1 : subroutine access_get_complex_dp(self, path, val, default)
415 : class(hsd_access_t), intent(inout) :: self
416 : character(len=*), intent(in) :: path
417 : complex(dp), intent(out) :: val
418 : complex(dp), intent(in), optional :: default
419 :
420 : type(hsd_node_t), pointer :: vnode
421 1 : integer :: local_stat
422 :
423 1 : call self%resolve_value_node(path, vnode, local_stat)
424 1 : if (local_stat == HSD_STAT_OK) then
425 1 : call vnode%get_complex(val, local_stat)
426 1 : if (local_stat /= HSD_STAT_OK) then
427 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
428 0 : & "Cannot parse as complex")
429 0 : val = (0.0_dp, 0.0_dp)
430 : end if
431 1 : return
432 : end if
433 :
434 0 : if (present(default)) then
435 0 : val = default
436 0 : if (self%on_missing == HSD_ON_MISSING_SET) then
437 0 : call hsd_set(self%root, path, default)
438 0 : call self%mark_path_processed(path)
439 : end if
440 : else
441 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
442 0 : & "Required complex field not found")
443 0 : val = (0.0_dp, 0.0_dp)
444 : end if
445 4 : end subroutine access_get_complex_dp
446 :
447 : ! ===== Array Getters =====
448 :
449 : !> Get integer array by path
450 6 : subroutine access_get_integer_array(self, path, val, default)
451 : class(hsd_access_t), intent(inout) :: self
452 : character(len=*), intent(in) :: path
453 : integer, allocatable, intent(out) :: val(:)
454 : integer, intent(in), optional :: default(:)
455 :
456 : type(hsd_node_t), pointer :: vnode
457 3 : integer :: local_stat
458 :
459 3 : call self%resolve_value_node(path, vnode, local_stat)
460 3 : if (local_stat == HSD_STAT_OK) then
461 2 : call vnode%get_int_array(val, local_stat)
462 2 : if (local_stat /= HSD_STAT_OK) then
463 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
464 0 : & "Cannot parse as integer array")
465 0 : allocate(val(0))
466 : end if
467 2 : return
468 : end if
469 :
470 1 : if (present(default)) then
471 4 : val = default
472 1 : if (self%on_missing == HSD_ON_MISSING_SET) then
473 1 : call hsd_set(self%root, path, default)
474 1 : call self%mark_path_processed(path)
475 : end if
476 : else
477 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
478 0 : & "Required integer array field not found")
479 0 : allocate(val(0))
480 : end if
481 4 : end subroutine access_get_integer_array
482 :
483 : !> Get double precision real array by path
484 4 : subroutine access_get_real_dp_array(self, path, val, default)
485 : class(hsd_access_t), intent(inout) :: self
486 : character(len=*), intent(in) :: path
487 : real(dp), allocatable, intent(out) :: val(:)
488 : real(dp), intent(in), optional :: default(:)
489 :
490 : type(hsd_node_t), pointer :: vnode
491 2 : integer :: local_stat
492 :
493 2 : call self%resolve_value_node(path, vnode, local_stat)
494 2 : if (local_stat == HSD_STAT_OK) then
495 2 : call vnode%get_real_array(val, local_stat)
496 2 : if (local_stat /= HSD_STAT_OK) then
497 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
498 0 : & "Cannot parse as real array")
499 0 : allocate(val(0))
500 : end if
501 2 : return
502 : end if
503 :
504 0 : if (present(default)) then
505 0 : val = default
506 0 : if (self%on_missing == HSD_ON_MISSING_SET) then
507 0 : call hsd_set(self%root, path, default)
508 0 : call self%mark_path_processed(path)
509 : end if
510 : else
511 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
512 0 : & "Required real array field not found")
513 0 : allocate(val(0))
514 : end if
515 5 : end subroutine access_get_real_dp_array
516 :
517 : !> Get logical array by path
518 2 : subroutine access_get_logical_array(self, path, val, default)
519 : class(hsd_access_t), intent(inout) :: self
520 : character(len=*), intent(in) :: path
521 : logical, allocatable, intent(out) :: val(:)
522 : logical, intent(in), optional :: default(:)
523 :
524 : type(hsd_node_t), pointer :: vnode
525 1 : integer :: local_stat
526 :
527 1 : call self%resolve_value_node(path, vnode, local_stat)
528 1 : if (local_stat == HSD_STAT_OK) then
529 1 : call vnode%get_logical_array(val, local_stat)
530 1 : if (local_stat /= HSD_STAT_OK) then
531 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
532 0 : & "Cannot parse as logical array")
533 0 : allocate(val(0))
534 : end if
535 1 : return
536 : end if
537 :
538 0 : if (present(default)) then
539 0 : val = default
540 0 : if (self%on_missing == HSD_ON_MISSING_SET) then
541 0 : call hsd_set(self%root, path, default)
542 0 : call self%mark_path_processed(path)
543 : end if
544 : else
545 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
546 0 : & "Required logical array field not found")
547 0 : allocate(val(0))
548 : end if
549 3 : end subroutine access_get_logical_array
550 :
551 : !> Get string array by path
552 2 : subroutine access_get_string_array(self, path, val, default)
553 : class(hsd_access_t), intent(inout) :: self
554 : character(len=*), intent(in) :: path
555 : character(len=:), allocatable, intent(out) :: val(:)
556 : character(len=*), intent(in), optional :: default(:)
557 :
558 : type(hsd_node_t), pointer :: vnode
559 1 : integer :: local_stat
560 :
561 1 : call self%resolve_value_node(path, vnode, local_stat)
562 1 : if (local_stat == HSD_STAT_OK) then
563 1 : call vnode%get_string_array(val, local_stat)
564 1 : if (local_stat /= HSD_STAT_OK) then
565 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
566 0 : & "Cannot parse as string array")
567 0 : allocate(character(len=0) :: val(0))
568 : end if
569 1 : return
570 : end if
571 :
572 0 : if (present(default)) then
573 0 : val = default
574 0 : if (self%on_missing == HSD_ON_MISSING_SET) then
575 0 : call hsd_set(self%root, path, default)
576 0 : call self%mark_path_processed(path)
577 : end if
578 : else
579 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
580 0 : & "Required string array field not found")
581 0 : allocate(character(len=0) :: val(0))
582 : end if
583 2 : end subroutine access_get_string_array
584 :
585 : !> Get complex double precision array by path
586 2 : subroutine access_get_complex_dp_array(self, path, val, default)
587 : class(hsd_access_t), intent(inout) :: self
588 : character(len=*), intent(in) :: path
589 : complex(dp), allocatable, intent(out) :: val(:)
590 : complex(dp), intent(in), optional :: default(:)
591 :
592 : type(hsd_node_t), pointer :: vnode
593 1 : integer :: local_stat
594 :
595 1 : call self%resolve_value_node(path, vnode, local_stat)
596 1 : if (local_stat == HSD_STAT_OK) then
597 1 : call vnode%get_complex_array(val, local_stat)
598 1 : if (local_stat /= HSD_STAT_OK) then
599 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
600 0 : & "Cannot parse as complex array")
601 0 : allocate(val(0))
602 : end if
603 1 : return
604 : end if
605 :
606 0 : if (present(default)) then
607 0 : val = default
608 0 : if (self%on_missing == HSD_ON_MISSING_SET) then
609 0 : call hsd_set(self%root, path, default)
610 0 : call self%mark_path_processed(path)
611 : end if
612 : else
613 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
614 0 : & "Required complex array field not found")
615 0 : allocate(val(0))
616 : end if
617 2 : end subroutine access_get_complex_dp_array
618 :
619 : ! ===== Matrix Getters =====
620 :
621 : !> Get integer matrix by path
622 0 : subroutine access_get_int_matrix(self, path, val, nrows, ncols, order)
623 : class(hsd_access_t), intent(inout) :: self
624 : character(len=*), intent(in) :: path
625 : integer, allocatable, intent(out) :: val(:,:)
626 : integer, intent(out) :: nrows, ncols
627 : character(len=*), intent(in), optional :: order
628 :
629 : type(hsd_node_t), pointer :: child
630 0 : integer :: local_stat
631 0 : logical :: was_processed
632 :
633 : ! Save processed state to restore if mark_processed is off
634 0 : was_processed = .false.
635 0 : call hsd_get_child(self%root, path, child, local_stat)
636 0 : if (local_stat == HSD_STAT_OK .and. associated(child)) &
637 0 : & was_processed = child%processed
638 :
639 0 : call hsd_get_matrix(self%root, path, val, nrows, ncols, &
640 0 : & local_stat, order)
641 :
642 0 : if (local_stat /= HSD_STAT_OK) then
643 : call self%push_error(path, local_stat, &
644 0 : & "Cannot read integer matrix")
645 0 : return
646 : end if
647 :
648 0 : if (.not. self%mark_processed .and. associated(child)) &
649 0 : & child%processed = was_processed
650 1 : end subroutine access_get_int_matrix
651 :
652 : !> Get double precision real matrix by path
653 2 : subroutine access_get_real_matrix(self, path, val, nrows, ncols, order)
654 : class(hsd_access_t), intent(inout) :: self
655 : character(len=*), intent(in) :: path
656 : real(dp), allocatable, intent(out) :: val(:,:)
657 : integer, intent(out) :: nrows, ncols
658 : character(len=*), intent(in), optional :: order
659 :
660 : type(hsd_node_t), pointer :: child
661 2 : integer :: local_stat
662 2 : logical :: was_processed
663 :
664 2 : was_processed = .false.
665 2 : call hsd_get_child(self%root, path, child, local_stat)
666 2 : if (local_stat == HSD_STAT_OK .and. associated(child)) &
667 2 : & was_processed = child%processed
668 :
669 0 : call hsd_get_matrix(self%root, path, val, nrows, ncols, &
670 2 : & local_stat, order)
671 :
672 2 : if (local_stat /= HSD_STAT_OK) then
673 : call self%push_error(path, local_stat, &
674 0 : & "Cannot read real matrix")
675 0 : return
676 : end if
677 :
678 2 : if (.not. self%mark_processed .and. associated(child)) &
679 0 : & child%processed = was_processed
680 2 : end subroutine access_get_real_matrix
681 :
682 : !> Get complex double precision matrix by path
683 0 : subroutine access_get_complex_matrix(self, path, val, nrows, ncols, &
684 : & order)
685 : class(hsd_access_t), intent(inout) :: self
686 : character(len=*), intent(in) :: path
687 : complex(dp), allocatable, intent(out) :: val(:,:)
688 : integer, intent(out) :: nrows, ncols
689 : character(len=*), intent(in), optional :: order
690 :
691 : type(hsd_node_t), pointer :: child
692 0 : integer :: local_stat
693 0 : logical :: was_processed
694 :
695 0 : was_processed = .false.
696 0 : call hsd_get_child(self%root, path, child, local_stat)
697 0 : if (local_stat == HSD_STAT_OK .and. associated(child)) &
698 0 : & was_processed = child%processed
699 :
700 0 : call hsd_get_matrix(self%root, path, val, nrows, ncols, &
701 0 : & local_stat, order)
702 :
703 0 : if (local_stat /= HSD_STAT_OK) then
704 : call self%push_error(path, local_stat, &
705 0 : & "Cannot read complex matrix")
706 0 : return
707 : end if
708 :
709 0 : if (.not. self%mark_processed .and. associated(child)) &
710 0 : & child%processed = was_processed
711 2 : end subroutine access_get_complex_matrix
712 :
713 : ! ===== Scalar Setters =====
714 :
715 : !> Set string value by path
716 1 : subroutine access_set_string(self, path, val)
717 : class(hsd_access_t), intent(inout) :: self
718 : character(len=*), intent(in) :: path
719 : character(len=*), intent(in) :: val
720 :
721 1 : integer :: local_stat
722 :
723 1 : call hsd_set(self%root, path, val, local_stat)
724 1 : if (local_stat /= HSD_STAT_OK) &
725 : & call self%push_error(path, local_stat, &
726 0 : & "Failed to set string value")
727 0 : end subroutine access_set_string
728 :
729 : !> Set integer value by path
730 1 : subroutine access_set_integer(self, path, val)
731 : class(hsd_access_t), intent(inout) :: self
732 : character(len=*), intent(in) :: path
733 : integer, intent(in) :: val
734 :
735 1 : integer :: local_stat
736 :
737 1 : call hsd_set(self%root, path, val, local_stat)
738 1 : if (local_stat /= HSD_STAT_OK) &
739 : & call self%push_error(path, local_stat, &
740 0 : & "Failed to set integer value")
741 1 : end subroutine access_set_integer
742 :
743 : !> Set double precision real value by path
744 1 : subroutine access_set_real_dp(self, path, val)
745 : class(hsd_access_t), intent(inout) :: self
746 : character(len=*), intent(in) :: path
747 : real(dp), intent(in) :: val
748 :
749 1 : integer :: local_stat
750 :
751 1 : call hsd_set(self%root, path, val, local_stat)
752 1 : if (local_stat /= HSD_STAT_OK) &
753 : & call self%push_error(path, local_stat, &
754 0 : & "Failed to set real value")
755 1 : end subroutine access_set_real_dp
756 :
757 : !> Set logical value by path
758 1 : subroutine access_set_logical(self, path, val)
759 : class(hsd_access_t), intent(inout) :: self
760 : character(len=*), intent(in) :: path
761 : logical, intent(in) :: val
762 :
763 1 : integer :: local_stat
764 :
765 1 : call hsd_set(self%root, path, val, local_stat)
766 1 : if (local_stat /= HSD_STAT_OK) &
767 : & call self%push_error(path, local_stat, &
768 0 : & "Failed to set logical value")
769 1 : end subroutine access_set_logical
770 :
771 : !> Set complex double precision value by path
772 0 : subroutine access_set_complex_dp(self, path, val)
773 : class(hsd_access_t), intent(inout) :: self
774 : character(len=*), intent(in) :: path
775 : complex(dp), intent(in) :: val
776 :
777 0 : integer :: local_stat
778 :
779 0 : call hsd_set(self%root, path, val, local_stat)
780 0 : if (local_stat /= HSD_STAT_OK) &
781 : & call self%push_error(path, local_stat, &
782 0 : & "Failed to set complex value")
783 1 : end subroutine access_set_complex_dp
784 :
785 : ! ===== Array Setters =====
786 :
787 : !> Set integer array by path
788 2 : subroutine access_set_integer_array(self, path, val)
789 : class(hsd_access_t), intent(inout) :: self
790 : character(len=*), intent(in) :: path
791 : integer, intent(in) :: val(:)
792 :
793 1 : integer :: local_stat
794 :
795 1 : call hsd_set(self%root, path, val, local_stat)
796 1 : if (local_stat /= HSD_STAT_OK) &
797 : & call self%push_error(path, local_stat, &
798 0 : & "Failed to set integer array")
799 0 : end subroutine access_set_integer_array
800 :
801 : !> Set double precision real array by path
802 2 : subroutine access_set_real_dp_array(self, path, val)
803 : class(hsd_access_t), intent(inout) :: self
804 : character(len=*), intent(in) :: path
805 : real(dp), intent(in) :: val(:)
806 :
807 1 : integer :: local_stat
808 :
809 1 : call hsd_set(self%root, path, val, local_stat)
810 1 : if (local_stat /= HSD_STAT_OK) &
811 : & call self%push_error(path, local_stat, &
812 0 : & "Failed to set real array")
813 1 : end subroutine access_set_real_dp_array
814 :
815 : !> Set logical array by path
816 0 : subroutine access_set_logical_array(self, path, val)
817 : class(hsd_access_t), intent(inout) :: self
818 : character(len=*), intent(in) :: path
819 : logical, intent(in) :: val(:)
820 :
821 0 : integer :: local_stat
822 :
823 0 : call hsd_set(self%root, path, val, local_stat)
824 0 : if (local_stat /= HSD_STAT_OK) &
825 : & call self%push_error(path, local_stat, &
826 0 : & "Failed to set logical array")
827 1 : end subroutine access_set_logical_array
828 :
829 : !> Set string array by path
830 0 : subroutine access_set_string_array(self, path, val)
831 : class(hsd_access_t), intent(inout) :: self
832 : character(len=*), intent(in) :: path
833 : character(len=*), intent(in) :: val(:)
834 :
835 0 : integer :: local_stat
836 :
837 0 : call hsd_set(self%root, path, val, local_stat)
838 0 : if (local_stat /= HSD_STAT_OK) &
839 : & call self%push_error(path, local_stat, &
840 0 : & "Failed to set string array")
841 0 : end subroutine access_set_string_array
842 :
843 : !> Set complex double precision array by path
844 0 : subroutine access_set_complex_dp_array(self, path, val)
845 : class(hsd_access_t), intent(inout) :: self
846 : character(len=*), intent(in) :: path
847 : complex(dp), intent(in) :: val(:)
848 :
849 0 : integer :: local_stat
850 :
851 0 : call hsd_set(self%root, path, val, local_stat)
852 0 : if (local_stat /= HSD_STAT_OK) &
853 : & call self%push_error(path, local_stat, &
854 0 : & "Failed to set complex array")
855 0 : end subroutine access_set_complex_dp_array
856 :
857 : ! ===== Matrix Setters =====
858 :
859 : !> Set integer matrix by path
860 0 : subroutine access_set_integer_matrix(self, path, val)
861 : class(hsd_access_t), intent(inout) :: self
862 : character(len=*), intent(in) :: path
863 : integer, intent(in) :: val(:,:)
864 :
865 0 : integer :: local_stat
866 :
867 0 : call hsd_set(self%root, path, val, local_stat)
868 0 : if (local_stat /= HSD_STAT_OK) &
869 : & call self%push_error(path, local_stat, &
870 0 : & "Failed to set integer matrix")
871 0 : end subroutine access_set_integer_matrix
872 :
873 : !> Set double precision real matrix by path
874 2 : subroutine access_set_real_dp_matrix(self, path, val)
875 : class(hsd_access_t), intent(inout) :: self
876 : character(len=*), intent(in) :: path
877 : real(dp), intent(in) :: val(:,:)
878 :
879 1 : integer :: local_stat
880 :
881 1 : call hsd_set(self%root, path, val, local_stat)
882 1 : if (local_stat /= HSD_STAT_OK) &
883 : & call self%push_error(path, local_stat, &
884 0 : & "Failed to set real matrix")
885 0 : end subroutine access_set_real_dp_matrix
886 :
887 : !> Set complex double precision matrix by path
888 0 : subroutine access_set_complex_dp_matrix(self, path, val)
889 : class(hsd_access_t), intent(inout) :: self
890 : character(len=*), intent(in) :: path
891 : complex(dp), intent(in) :: val(:,:)
892 :
893 0 : integer :: local_stat
894 :
895 0 : call hsd_set(self%root, path, val, local_stat)
896 0 : if (local_stat /= HSD_STAT_OK) &
897 : & call self%push_error(path, local_stat, &
898 0 : & "Failed to set complex matrix")
899 1 : end subroutine access_set_complex_dp_matrix
900 :
901 : ! ===== Choice Getter =====
902 :
903 : !> Get a polymorphic choice (first table child of a block)
904 : !>
905 : !> Returns the lowercase name of the chosen child table and a pointer to it.
906 : !> Pushes an error if the path doesn't exist or contains no table child.
907 2 : subroutine access_get_choice(self, path, choice_name, choice_table)
908 : class(hsd_access_t), intent(inout) :: self
909 : character(len=*), intent(in) :: path
910 : character(len=:), allocatable, intent(out) :: choice_name
911 : type(hsd_node_t), pointer, intent(out) :: choice_table
912 :
913 : type(hsd_node_t), pointer :: table_node, child
914 2 : integer :: local_stat, ii
915 :
916 2 : nullify(choice_table)
917 2 : choice_name = ""
918 :
919 2 : call hsd_get_child(self%root, path, table_node, local_stat)
920 2 : if (local_stat /= HSD_STAT_OK .or. .not. associated(table_node)) then
921 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
922 1 : & "Choice block not found")
923 1 : return
924 : end if
925 :
926 1 : if (self%mark_processed) table_node%processed = .true.
927 :
928 1 : if (table_node%node_type /= NODE_TYPE_TABLE) then
929 : call self%push_error(path, HSD_STAT_TYPE_ERROR, &
930 0 : & "Choice block is not a table")
931 0 : return
932 : end if
933 :
934 1 : do ii = 1, table_node%num_children
935 1 : call table_node%get_child(ii, child)
936 1 : if (.not. associated(child)) cycle
937 1 : if (child%node_type == NODE_TYPE_TABLE) then
938 1 : choice_table => child
939 1 : if (allocated(child%name)) then
940 1 : choice_name = to_lower(child%name)
941 : end if
942 1 : if (self%mark_processed) choice_table%processed = .true.
943 1 : return
944 : end if
945 : end do
946 :
947 : call self%push_error(path, HSD_STAT_NOT_FOUND, &
948 0 : & "No choice found in block")
949 2 : end subroutine access_get_choice
950 :
951 80 : end module hsd_access
|
