Line data Source code
1 : !> HSD data accessors (getters)
2 : !>
3 : !> This module provides interfaces and implementations for retrieving data
4 : !> from HSD tables. It supports type-safe access to scalars, arrays, and
5 : !> matrices with optional default values.
6 : module hsd_accessors
7 : use hsd_constants, only: dp, sp
8 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_NOT_FOUND, HSD_STAT_TYPE_ERROR
9 : use hsd_types, only: hsd_node, hsd_table, hsd_value, new_value, VALUE_TYPE_ARRAY
10 : implicit none (type, external)
11 : private
12 :
13 : ! Public interfaces
14 : public :: hsd_get, hsd_get_or, hsd_get_matrix
15 :
16 : !> Generic interface for getting values
17 : !>
18 : !> All procedures accept an optional `stat` parameter for error status.
19 : !> Use `hsd_get_or` for fallback default values when key is not found.
20 : interface hsd_get
21 : module procedure :: hsd_get_string
22 : module procedure :: hsd_get_integer
23 : module procedure :: hsd_get_real_dp
24 : module procedure :: hsd_get_real_sp
25 : module procedure :: hsd_get_logical
26 : module procedure :: hsd_get_complex_dp
27 : module procedure :: hsd_get_integer_array
28 : module procedure :: hsd_get_real_dp_array
29 : module procedure :: hsd_get_real_sp_array
30 : module procedure :: hsd_get_logical_array
31 : module procedure :: hsd_get_string_array
32 : module procedure :: hsd_get_complex_dp_array
33 : end interface hsd_get
34 :
35 : !> Generic interface for getting values with default fallback
36 : !>
37 : !> Returns the default value if the key is not found.
38 : !> stat will be HSD_STAT_NOT_FOUND when default is used, HSD_STAT_OK otherwise.
39 : interface hsd_get_or
40 : module procedure :: hsd_get_string_default
41 : module procedure :: hsd_get_integer_default
42 : module procedure :: hsd_get_real_dp_default
43 : module procedure :: hsd_get_real_sp_default
44 : module procedure :: hsd_get_logical_default
45 : module procedure :: hsd_get_complex_dp_default
46 : end interface hsd_get_or
47 :
48 : !> Generic interface for getting 2D matrices
49 : interface hsd_get_matrix
50 : module procedure :: hsd_get_integer_matrix
51 : module procedure :: hsd_get_real_dp_matrix
52 : end interface hsd_get_matrix
53 :
54 : contains
55 :
56 : !> Get string value by path
57 28 : subroutine hsd_get_string(table, path, val, stat)
58 : type(hsd_table), intent(in), target :: table
59 : character(len=*), intent(in) :: path
60 : character(len=:), allocatable, intent(out) :: val
61 : integer, intent(out), optional :: stat
62 :
63 : class(hsd_node), pointer :: child
64 28 : integer :: local_stat
65 :
66 28 : call get_child_by_path(table, path, child, local_stat)
67 :
68 28 : if (local_stat /= 0 .or. .not. associated(child)) then
69 4 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
70 4 : val = ""
71 4 : return
72 : end if
73 :
74 : select type (child)
75 : type is (hsd_value)
76 22 : call child%get_string(val, local_stat)
77 44 : if (present(stat)) stat = local_stat
78 : class default
79 2 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
80 2 : val = ""
81 : end select
82 :
83 28 : end subroutine hsd_get_string
84 :
85 : !> Get string value by path with default fallback
86 3 : subroutine hsd_get_string_default(table, path, val, default, stat)
87 : type(hsd_table), intent(in), target :: table
88 : character(len=*), intent(in) :: path
89 : character(len=:), allocatable, intent(out) :: val
90 : character(len=*), intent(in) :: default
91 : integer, intent(out), optional :: stat
92 :
93 3 : integer :: local_stat
94 :
95 3 : call hsd_get_string(table, path, val, local_stat)
96 :
97 3 : if (local_stat /= 0) then
98 2 : val = default
99 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
100 : else
101 1 : if (present(stat)) stat = HSD_STAT_OK
102 : end if
103 :
104 28 : end subroutine hsd_get_string_default
105 :
106 : !> Get integer value by path
107 100062 : subroutine hsd_get_integer(table, path, val, stat)
108 : type(hsd_table), intent(in), target :: table
109 : character(len=*), intent(in) :: path
110 : integer, intent(out) :: val
111 : integer, intent(out), optional :: stat
112 :
113 : class(hsd_node), pointer :: child
114 100062 : integer :: local_stat
115 :
116 100062 : call get_child_by_path(table, path, child, local_stat)
117 :
118 100062 : if (local_stat /= 0 .or. .not. associated(child)) then
119 5 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
120 5 : val = 0
121 5 : return
122 : end if
123 :
124 : select type (child)
125 : type is (hsd_value)
126 100056 : call child%get_integer(val, local_stat)
127 200112 : if (present(stat)) stat = local_stat
128 : class default
129 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
130 1 : val = 0
131 : end select
132 :
133 100065 : end subroutine hsd_get_integer
134 :
135 : !> Get integer value by path with default fallback
136 3 : subroutine hsd_get_integer_default(table, path, val, default, stat)
137 : type(hsd_table), intent(in), target :: table
138 : character(len=*), intent(in) :: path
139 : integer, intent(out) :: val
140 : integer, intent(in) :: default
141 : integer, intent(out), optional :: stat
142 :
143 3 : integer :: local_stat
144 :
145 3 : call hsd_get_integer(table, path, val, local_stat)
146 :
147 3 : if (local_stat /= 0) then
148 2 : val = default
149 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
150 : else
151 1 : if (present(stat)) stat = HSD_STAT_OK
152 : end if
153 :
154 100062 : end subroutine hsd_get_integer_default
155 :
156 : !> Get double precision real value by path
157 24 : subroutine hsd_get_real_dp(table, path, val, stat)
158 : type(hsd_table), intent(in), target :: table
159 : character(len=*), intent(in) :: path
160 : real(dp), intent(out) :: val
161 : integer, intent(out), optional :: stat
162 :
163 : class(hsd_node), pointer :: child
164 24 : integer :: local_stat
165 :
166 24 : call get_child_by_path(table, path, child, local_stat)
167 :
168 24 : if (local_stat /= 0 .or. .not. associated(child)) then
169 6 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
170 6 : val = 0.0_dp
171 6 : return
172 : end if
173 :
174 : select type (child)
175 : type is (hsd_value)
176 17 : call child%get_real(val, local_stat)
177 34 : if (present(stat)) stat = local_stat
178 : class default
179 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
180 1 : val = 0.0_dp
181 : end select
182 :
183 27 : end subroutine hsd_get_real_dp
184 :
185 : !> Get double precision real value by path with default fallback
186 3 : subroutine hsd_get_real_dp_default(table, path, val, default, stat)
187 : type(hsd_table), intent(in), target :: table
188 : character(len=*), intent(in) :: path
189 : real(dp), intent(out) :: val
190 : real(dp), intent(in) :: default
191 : integer, intent(out), optional :: stat
192 :
193 3 : integer :: local_stat
194 :
195 3 : call hsd_get_real_dp(table, path, val, local_stat)
196 :
197 3 : if (local_stat /= 0) then
198 2 : val = default
199 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
200 : else
201 1 : if (present(stat)) stat = HSD_STAT_OK
202 : end if
203 :
204 24 : end subroutine hsd_get_real_dp_default
205 :
206 : !> Get single precision real value by path
207 7 : subroutine hsd_get_real_sp(table, path, val, stat)
208 : type(hsd_table), intent(in), target :: table
209 : character(len=*), intent(in) :: path
210 : real(sp), intent(out) :: val
211 : integer, intent(out), optional :: stat
212 :
213 7 : real(dp) :: val_dp
214 7 : integer :: local_stat
215 :
216 7 : call hsd_get_real_dp(table, path, val_dp, local_stat)
217 7 : val = real(val_dp, sp)
218 7 : if (present(stat)) stat = local_stat
219 :
220 3 : end subroutine hsd_get_real_sp
221 :
222 : !> Get single precision real value by path with default fallback
223 2 : subroutine hsd_get_real_sp_default(table, path, val, default, stat)
224 : type(hsd_table), intent(in), target :: table
225 : character(len=*), intent(in) :: path
226 : real(sp), intent(out) :: val
227 : real(sp), intent(in) :: default
228 : integer, intent(out), optional :: stat
229 :
230 2 : integer :: local_stat
231 :
232 2 : call hsd_get_real_sp(table, path, val, local_stat)
233 :
234 2 : if (local_stat /= 0) then
235 2 : val = default
236 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
237 : else
238 0 : if (present(stat)) stat = HSD_STAT_OK
239 : end if
240 :
241 7 : end subroutine hsd_get_real_sp_default
242 :
243 : !> Get logical value by path
244 24 : subroutine hsd_get_logical(table, path, val, stat)
245 : type(hsd_table), intent(in), target :: table
246 : character(len=*), intent(in) :: path
247 : logical, intent(out) :: val
248 : integer, intent(out), optional :: stat
249 :
250 : class(hsd_node), pointer :: child
251 24 : integer :: local_stat
252 :
253 24 : call get_child_by_path(table, path, child, local_stat)
254 :
255 24 : if (local_stat /= 0 .or. .not. associated(child)) then
256 4 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
257 4 : val = .false.
258 4 : return
259 : end if
260 :
261 : select type (child)
262 : type is (hsd_value)
263 19 : call child%get_logical(val, local_stat)
264 38 : if (present(stat)) stat = local_stat
265 : class default
266 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
267 1 : val = .false.
268 : end select
269 :
270 26 : end subroutine hsd_get_logical
271 :
272 : !> Get logical value by path with default fallback
273 3 : subroutine hsd_get_logical_default(table, path, val, default, stat)
274 : type(hsd_table), intent(in), target :: table
275 : character(len=*), intent(in) :: path
276 : logical, intent(out) :: val
277 : logical, intent(in) :: default
278 : integer, intent(out), optional :: stat
279 :
280 3 : integer :: local_stat
281 :
282 3 : call hsd_get_logical(table, path, val, local_stat)
283 :
284 3 : if (local_stat /= 0) then
285 2 : val = default
286 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
287 : else
288 1 : if (present(stat)) stat = HSD_STAT_OK
289 : end if
290 :
291 24 : end subroutine hsd_get_logical_default
292 :
293 : !> Get complex value by path
294 40 : subroutine hsd_get_complex_dp(table, path, val, stat)
295 : type(hsd_table), intent(in), target :: table
296 : character(len=*), intent(in) :: path
297 : complex(dp), intent(out) :: val
298 : integer, intent(out), optional :: stat
299 :
300 : class(hsd_node), pointer :: child
301 40 : integer :: local_stat
302 :
303 40 : call get_child_by_path(table, path, child, local_stat)
304 :
305 40 : if (local_stat /= 0 .or. .not. associated(child)) then
306 4 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
307 4 : val = (0.0_dp, 0.0_dp)
308 4 : return
309 : end if
310 :
311 : select type (child)
312 : type is (hsd_value)
313 35 : call child%get_complex(val, local_stat)
314 70 : if (present(stat)) stat = local_stat
315 : class default
316 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
317 1 : val = (0.0_dp, 0.0_dp)
318 : end select
319 :
320 43 : end subroutine hsd_get_complex_dp
321 :
322 : !> Get complex value by path with default fallback
323 3 : subroutine hsd_get_complex_dp_default(table, path, val, default, stat)
324 : type(hsd_table), intent(in), target :: table
325 : character(len=*), intent(in) :: path
326 : complex(dp), intent(out) :: val
327 : complex(dp), intent(in) :: default
328 : integer, intent(out), optional :: stat
329 :
330 3 : integer :: local_stat
331 :
332 3 : call hsd_get_complex_dp(table, path, val, local_stat)
333 :
334 3 : if (local_stat /= 0) then
335 2 : val = default
336 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
337 : else
338 1 : if (present(stat)) stat = HSD_STAT_OK
339 : end if
340 :
341 40 : end subroutine hsd_get_complex_dp_default
342 :
343 : !> Get integer array by path (supports space/comma/newline separated values)
344 21 : subroutine hsd_get_integer_array(table, path, val, stat)
345 : type(hsd_table), intent(in), target :: table
346 : character(len=*), intent(in) :: path
347 : integer, allocatable, intent(out) :: val(:)
348 : integer, intent(out), optional :: stat
349 :
350 : class(hsd_node), pointer :: child
351 21 : integer :: local_stat
352 :
353 21 : call get_child_by_path(table, path, child, local_stat)
354 :
355 21 : if (local_stat /= 0 .or. .not. associated(child)) then
356 2 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
357 2 : allocate(val(0))
358 2 : return
359 : end if
360 :
361 : select type (child)
362 : type is (hsd_value)
363 16 : call child%get_int_array(val, local_stat)
364 32 : if (present(stat)) stat = local_stat
365 : class default
366 3 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
367 3 : allocate(val(0))
368 : end select
369 :
370 24 : end subroutine hsd_get_integer_array
371 :
372 : !> Get double precision real array by path
373 10120 : subroutine hsd_get_real_dp_array(table, path, val, stat)
374 : type(hsd_table), intent(in), target :: table
375 : character(len=*), intent(in) :: path
376 : real(dp), allocatable, intent(out) :: val(:)
377 : integer, intent(out), optional :: stat
378 :
379 : class(hsd_node), pointer :: child
380 10120 : integer :: local_stat
381 :
382 10120 : call get_child_by_path(table, path, child, local_stat)
383 :
384 10120 : if (local_stat /= 0 .or. .not. associated(child)) then
385 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
386 3 : allocate(val(0))
387 3 : return
388 : end if
389 :
390 : select type (child)
391 : type is (hsd_value)
392 16 : call child%get_real_array(val, local_stat)
393 32 : if (present(stat)) stat = local_stat
394 : class default
395 10101 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
396 10101 : allocate(val(0))
397 : end select
398 :
399 10141 : end subroutine hsd_get_real_dp_array
400 :
401 : !> Get single precision real array by path
402 8 : subroutine hsd_get_real_sp_array(table, path, val, stat)
403 : type(hsd_table), intent(in), target :: table
404 : character(len=*), intent(in) :: path
405 : real(sp), allocatable, intent(out) :: val(:)
406 : integer, intent(out), optional :: stat
407 :
408 8 : real(dp), allocatable :: val_dp(:)
409 8 : integer :: local_stat
410 :
411 0 : call hsd_get_real_dp_array(table, path, val_dp, local_stat)
412 :
413 8 : if (local_stat /= 0) then
414 2 : if (present(stat)) stat = local_stat
415 2 : allocate(val(0))
416 2 : return
417 : end if
418 :
419 6 : allocate(val(size(val_dp)))
420 23 : val = real(val_dp, sp)
421 6 : if (present(stat)) stat = HSD_STAT_OK
422 :
423 10136 : end subroutine hsd_get_real_sp_array
424 :
425 : !> Get logical array by path
426 9 : subroutine hsd_get_logical_array(table, path, val, stat)
427 : type(hsd_table), intent(in), target :: table
428 : character(len=*), intent(in) :: path
429 : logical, allocatable, intent(out) :: val(:)
430 : integer, intent(out), optional :: stat
431 :
432 : class(hsd_node), pointer :: child
433 9 : integer :: local_stat
434 :
435 9 : call get_child_by_path(table, path, child, local_stat)
436 :
437 9 : if (local_stat /= 0 .or. .not. associated(child)) then
438 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
439 1 : allocate(val(0))
440 1 : return
441 : end if
442 :
443 : select type (child)
444 : type is (hsd_value)
445 7 : call child%get_logical_array(val, local_stat)
446 14 : if (present(stat)) stat = local_stat
447 : class default
448 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
449 1 : allocate(val(0))
450 : end select
451 :
452 17 : end subroutine hsd_get_logical_array
453 :
454 : !> Get string array by path (preserves quoted strings)
455 16 : subroutine hsd_get_string_array(table, path, val, stat)
456 : type(hsd_table), intent(in), target :: table
457 : character(len=*), intent(in) :: path
458 : character(len=:), allocatable, intent(out) :: val(:)
459 : integer, intent(out), optional :: stat
460 :
461 : class(hsd_node), pointer :: child
462 16 : integer :: local_stat
463 :
464 16 : call get_child_by_path(table, path, child, local_stat)
465 :
466 16 : if (local_stat /= 0 .or. .not. associated(child)) then
467 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
468 1 : allocate(character(len=1) :: val(0))
469 1 : return
470 : end if
471 :
472 : select type (child)
473 : type is (hsd_value)
474 14 : call child%get_string_array(val, local_stat)
475 28 : if (present(stat)) stat = local_stat
476 : class default
477 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
478 1 : allocate(character(len=1) :: val(0))
479 : end select
480 :
481 25 : end subroutine hsd_get_string_array
482 :
483 : !> Get complex array by path
484 8 : subroutine hsd_get_complex_dp_array(table, path, val, stat)
485 : type(hsd_table), intent(in), target :: table
486 : character(len=*), intent(in) :: path
487 : complex(dp), allocatable, intent(out) :: val(:)
488 : integer, intent(out), optional :: stat
489 :
490 : class(hsd_node), pointer :: child
491 8 : integer :: local_stat
492 :
493 8 : call get_child_by_path(table, path, child, local_stat)
494 :
495 8 : if (local_stat /= 0 .or. .not. associated(child)) then
496 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
497 1 : allocate(val(0))
498 1 : return
499 : end if
500 :
501 : select type (child)
502 : type is (hsd_value)
503 6 : call child%get_complex_array(val, local_stat)
504 12 : if (present(stat)) stat = local_stat
505 : class default
506 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
507 1 : allocate(val(0))
508 : end select
509 :
510 24 : end subroutine hsd_get_complex_dp_array
511 :
512 : !> Get 2D integer matrix by path (rows separated by newlines or semicolons)
513 : !> Handles both value nodes and table nodes (where content is in unnamed children)
514 17 : subroutine hsd_get_integer_matrix(table, path, val, nrows, ncols, stat)
515 : type(hsd_table), intent(in), target :: table
516 : character(len=*), intent(in) :: path
517 : integer, allocatable, intent(out) :: val(:,:)
518 : integer, intent(out) :: nrows, ncols
519 : integer, intent(out), optional :: stat
520 :
521 : class(hsd_node), pointer :: child
522 17 : integer :: local_stat
523 :
524 17 : call get_child_by_path(table, path, child, local_stat)
525 :
526 17 : if (local_stat /= 0 .or. .not. associated(child)) then
527 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
528 3 : allocate(val(0,0))
529 3 : nrows = 0
530 3 : ncols = 0
531 3 : return
532 : end if
533 :
534 : select type (child)
535 : type is (hsd_value)
536 4 : call child%get_int_matrix(val, nrows, ncols, local_stat)
537 8 : if (present(stat)) stat = local_stat
538 : type is (hsd_table)
539 : ! Table nodes store matrix data as unnamed child values
540 10 : call get_int_matrix_from_table(child, val, nrows, ncols, local_stat)
541 20 : if (present(stat)) stat = local_stat
542 : class default
543 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
544 0 : allocate(val(0,0))
545 0 : nrows = 0
546 0 : ncols = 0
547 : end select
548 :
549 25 : end subroutine hsd_get_integer_matrix
550 :
551 : !> Get 2D real matrix by path
552 : !> Handles both value nodes and table nodes (where content is in unnamed children)
553 13 : subroutine hsd_get_real_dp_matrix(table, path, val, nrows, ncols, stat)
554 : type(hsd_table), intent(in), target :: table
555 : character(len=*), intent(in) :: path
556 : real(dp), allocatable, intent(out) :: val(:,:)
557 : integer, intent(out) :: nrows, ncols
558 : integer, intent(out), optional :: stat
559 :
560 : class(hsd_node), pointer :: child
561 13 : integer :: local_stat
562 :
563 13 : call get_child_by_path(table, path, child, local_stat)
564 :
565 13 : if (local_stat /= 0 .or. .not. associated(child)) then
566 3 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
567 3 : allocate(val(0,0))
568 3 : nrows = 0
569 3 : ncols = 0
570 3 : return
571 : end if
572 :
573 : select type (child)
574 : type is (hsd_value)
575 3 : call child%get_real_matrix(val, nrows, ncols, local_stat)
576 6 : if (present(stat)) stat = local_stat
577 : type is (hsd_table)
578 : ! Table nodes store matrix data as unnamed child values
579 7 : call get_real_matrix_from_table(child, val, nrows, ncols, local_stat)
580 14 : if (present(stat)) stat = local_stat
581 : class default
582 0 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
583 0 : allocate(val(0,0))
584 0 : nrows = 0
585 0 : ncols = 0
586 : end select
587 :
588 30 : end subroutine hsd_get_real_dp_matrix
589 :
590 : !> Extract integer matrix from table with unnamed value children
591 10 : subroutine get_int_matrix_from_table(tbl, mat, nrows, ncols, stat)
592 : type(hsd_table), intent(in) :: tbl
593 : integer, allocatable, intent(out) :: mat(:,:)
594 : integer, intent(out) :: nrows, ncols, stat
595 :
596 : class(hsd_node), pointer :: child
597 10 : character(len=:), allocatable :: combined_text, str_val
598 10 : integer :: i, local_stat
599 :
600 : ! Combine all unnamed value children into single text
601 10 : combined_text = ""
602 17 : do i = 1, tbl%num_children
603 7 : call tbl%get_child(i, child)
604 17 : if (associated(child)) then
605 : select type (child)
606 : type is (hsd_value)
607 : ! Only include unnamed value nodes (raw text content)
608 7 : if (.not. allocated(child%name) .or. len_trim(child%name) == 0) then
609 6 : call child%get_string(str_val, local_stat)
610 6 : if (local_stat == 0 .and. len_trim(str_val) > 0) then
611 6 : if (len(combined_text) > 0) then
612 0 : combined_text = combined_text // char(10) // str_val
613 : else
614 6 : combined_text = str_val
615 : end if
616 : end if
617 : end if
618 : end select
619 : end if
620 : end do
621 :
622 10 : if (len_trim(combined_text) == 0) then
623 4 : allocate(mat(0,0))
624 4 : nrows = 0
625 4 : ncols = 0
626 4 : stat = HSD_STAT_OK
627 4 : return
628 : end if
629 :
630 : ! Parse the combined text as a matrix
631 66 : block
632 6 : type(hsd_value) :: temp_val
633 6 : call new_value(temp_val)
634 6 : call temp_val%set_raw(combined_text)
635 6 : call temp_val%get_int_matrix(mat, nrows, ncols, stat)
636 66 : call temp_val%destroy()
637 : end block
638 :
639 23 : end subroutine get_int_matrix_from_table
640 :
641 : !> Extract real matrix from table with unnamed value children
642 7 : subroutine get_real_matrix_from_table(tbl, mat, nrows, ncols, stat)
643 : type(hsd_table), intent(in) :: tbl
644 : real(dp), allocatable, intent(out) :: mat(:,:)
645 : integer, intent(out) :: nrows, ncols, stat
646 :
647 : class(hsd_node), pointer :: child
648 7 : character(len=:), allocatable :: combined_text, str_val
649 7 : integer :: i, local_stat
650 :
651 : ! Combine all unnamed value children into single text
652 7 : combined_text = ""
653 14 : do i = 1, tbl%num_children
654 7 : call tbl%get_child(i, child)
655 14 : if (associated(child)) then
656 : select type (child)
657 : type is (hsd_value)
658 : ! Only include unnamed value nodes (raw text content)
659 7 : if (.not. allocated(child%name) .or. len_trim(child%name) == 0) then
660 6 : call child%get_string(str_val, local_stat)
661 6 : if (local_stat == 0 .and. len_trim(str_val) > 0) then
662 6 : if (len(combined_text) > 0) then
663 0 : combined_text = combined_text // char(10) // str_val
664 : else
665 6 : combined_text = str_val
666 : end if
667 : end if
668 : end if
669 : end select
670 : end if
671 : end do
672 :
673 7 : if (len_trim(combined_text) == 0) then
674 1 : allocate(mat(0,0))
675 1 : nrows = 0
676 1 : ncols = 0
677 1 : stat = HSD_STAT_OK
678 1 : return
679 : end if
680 :
681 : ! Parse the combined text as a matrix
682 66 : block
683 6 : type(hsd_value) :: temp_val
684 6 : call new_value(temp_val)
685 6 : call temp_val%set_raw(combined_text)
686 6 : call temp_val%get_real_matrix(mat, nrows, ncols, stat)
687 66 : call temp_val%destroy()
688 : end block
689 :
690 17 : end subroutine get_real_matrix_from_table
691 :
692 : !> Helper to navigate path and get child (imported from hsd_query)
693 : !> This is a forward reference - actual implementation in hsd_query
694 510430 : recursive subroutine get_child_by_path(table, path, child, stat)
695 : type(hsd_table), intent(in), target :: table
696 : character(len=*), intent(in) :: path
697 : class(hsd_node), pointer, intent(out) :: child
698 : integer, intent(out), optional :: stat
699 :
700 510430 : character(len=:), allocatable :: remaining, segment
701 : class(hsd_node), pointer :: current
702 510430 : integer :: sep_pos
703 :
704 510430 : child => null()
705 510430 : remaining = path
706 :
707 : ! Get first segment
708 510430 : sep_pos = index(remaining, "/")
709 510430 : if (sep_pos > 0) then
710 400049 : segment = remaining(1:sep_pos-1)
711 400049 : remaining = remaining(sep_pos+1:)
712 : else
713 110381 : segment = remaining
714 110381 : remaining = ""
715 : end if
716 :
717 : ! Find child with this name
718 510430 : call table%get_child_by_name(segment, current, case_insensitive=.true.)
719 :
720 510430 : if (.not. associated(current)) then
721 37 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
722 110382 : return
723 : end if
724 :
725 : ! If no more path, return this node
726 510393 : if (len_trim(remaining) == 0) then
727 110345 : child => current
728 110345 : if (present(stat)) stat = HSD_STAT_OK
729 110345 : return
730 : end if
731 :
732 : ! Otherwise, recurse into child table
733 : select type (current)
734 : type is (hsd_table)
735 400048 : call get_child_by_path(current, remaining, child, stat)
736 : class default
737 0 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
738 : end select
739 :
740 1020867 : end subroutine get_child_by_path
741 :
742 1310521 : end module hsd_accessors
|
