Line data Source code
1 : !> HSD data mutators (setters)
2 : !>
3 : !> This module provides interfaces and implementations for modifying HSD tables.
4 : !> It supports type-safe setting of scalars and arrays, with automatic path
5 : !> creation for nested structures.
6 : module hsd_mutators
7 : use hsd_constants, only: dp, sp
8 : use hsd_utils, only: to_lower
9 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_NOT_FOUND
10 : use hsd_types, only: hsd_node, hsd_table, hsd_value, new_table, new_value
11 : implicit none (type, external)
12 : private
13 :
14 : ! Public interface
15 : public :: hsd_set
16 :
17 : !> Generic interface for setting values by path
18 : interface hsd_set
19 : module procedure :: hsd_set_string
20 : module procedure :: hsd_set_integer
21 : module procedure :: hsd_set_real_dp
22 : module procedure :: hsd_set_real_sp
23 : module procedure :: hsd_set_logical
24 : module procedure :: hsd_set_complex_dp
25 : module procedure :: hsd_set_integer_array
26 : module procedure :: hsd_set_real_dp_array
27 : module procedure :: hsd_set_real_sp_array
28 : module procedure :: hsd_set_logical_array
29 : module procedure :: hsd_set_complex_dp_array
30 : end interface hsd_set
31 :
32 : contains
33 :
34 : !> Set string value by path
35 5 : subroutine hsd_set_string(table, path, val, stat)
36 : type(hsd_table), intent(inout) :: table
37 : character(len=*), intent(in) :: path
38 : character(len=*), intent(in) :: val
39 : integer, intent(out), optional :: stat
40 :
41 : class(hsd_node), pointer :: child
42 5 : integer :: local_stat
43 :
44 5 : call get_or_create_child(table, path, child, local_stat)
45 :
46 5 : if (local_stat /= 0) then
47 1 : if (present(stat)) stat = local_stat
48 1 : return
49 : end if
50 :
51 : select type (child)
52 : type is (hsd_value)
53 4 : call child%set_string(val)
54 : end select
55 :
56 4 : if (present(stat)) stat = HSD_STAT_OK
57 :
58 5 : end subroutine hsd_set_string
59 :
60 : !> Set integer value by path
61 1014 : subroutine hsd_set_integer(table, path, val, stat)
62 : type(hsd_table), intent(inout) :: table
63 : character(len=*), intent(in) :: path
64 : integer, intent(in) :: val
65 : integer, intent(out), optional :: stat
66 :
67 : class(hsd_node), pointer :: child
68 1014 : integer :: local_stat
69 :
70 1014 : call get_or_create_child(table, path, child, local_stat)
71 :
72 1014 : if (local_stat /= 0) then
73 4 : if (present(stat)) stat = local_stat
74 4 : return
75 : end if
76 :
77 : select type (child)
78 : type is (hsd_value)
79 1010 : call child%set_integer(val)
80 : end select
81 :
82 1010 : if (present(stat)) stat = HSD_STAT_OK
83 :
84 1019 : end subroutine hsd_set_integer
85 :
86 : !> Set double precision real value by path
87 11 : subroutine hsd_set_real_dp(table, path, val, stat)
88 : type(hsd_table), intent(inout) :: table
89 : character(len=*), intent(in) :: path
90 : real(dp), intent(in) :: val
91 : integer, intent(out), optional :: stat
92 :
93 : class(hsd_node), pointer :: child
94 11 : integer :: local_stat
95 :
96 11 : call get_or_create_child(table, path, child, local_stat)
97 :
98 11 : if (local_stat /= 0) then
99 2 : if (present(stat)) stat = local_stat
100 2 : return
101 : end if
102 :
103 : select type (child)
104 : type is (hsd_value)
105 9 : call child%set_real(val)
106 : end select
107 :
108 9 : if (present(stat)) stat = HSD_STAT_OK
109 :
110 1025 : end subroutine hsd_set_real_dp
111 :
112 : !> Set single precision real value by path
113 5 : subroutine hsd_set_real_sp(table, path, val, stat)
114 : type(hsd_table), intent(inout) :: table
115 : character(len=*), intent(in) :: path
116 : real(sp), intent(in) :: val
117 : integer, intent(out), optional :: stat
118 :
119 5 : call hsd_set_real_dp(table, path, real(val, dp), stat)
120 :
121 11 : end subroutine hsd_set_real_sp
122 :
123 : !> Set logical value by path
124 5 : subroutine hsd_set_logical(table, path, val, stat)
125 : type(hsd_table), intent(inout) :: table
126 : character(len=*), intent(in) :: path
127 : logical, intent(in) :: val
128 : integer, intent(out), optional :: stat
129 :
130 : class(hsd_node), pointer :: child
131 5 : integer :: local_stat
132 :
133 5 : call get_or_create_child(table, path, child, local_stat)
134 :
135 5 : if (local_stat /= 0) then
136 1 : if (present(stat)) stat = local_stat
137 1 : return
138 : end if
139 :
140 : select type (child)
141 : type is (hsd_value)
142 4 : call child%set_logical(val)
143 : end select
144 :
145 4 : if (present(stat)) stat = HSD_STAT_OK
146 :
147 10 : end subroutine hsd_set_logical
148 :
149 : !> Set complex value by path
150 3 : subroutine hsd_set_complex_dp(table, path, val, stat)
151 : type(hsd_table), intent(inout) :: table
152 : character(len=*), intent(in) :: path
153 : complex(dp), intent(in) :: val
154 : integer, intent(out), optional :: stat
155 :
156 : class(hsd_node), pointer :: child
157 3 : integer :: local_stat
158 :
159 3 : call get_or_create_child(table, path, child, local_stat)
160 :
161 3 : if (local_stat /= 0) then
162 1 : if (present(stat)) stat = local_stat
163 1 : return
164 : end if
165 :
166 : select type (child)
167 : type is (hsd_value)
168 2 : call child%set_complex(val)
169 : end select
170 :
171 2 : if (present(stat)) stat = HSD_STAT_OK
172 :
173 8 : end subroutine hsd_set_complex_dp
174 :
175 : !> Set integer array by path
176 6 : subroutine hsd_set_integer_array(table, path, val, stat)
177 : type(hsd_table), intent(inout) :: table
178 : character(len=*), intent(in) :: path
179 : integer, intent(in) :: val(:)
180 : integer, intent(out), optional :: stat
181 :
182 : class(hsd_node), pointer :: child
183 3 : integer :: local_stat, i
184 3 : character(len=:), allocatable :: text
185 : character(len=32) :: buffer
186 :
187 3 : call get_or_create_child(table, path, child, local_stat)
188 :
189 3 : if (local_stat /= 0) then
190 1 : if (present(stat)) stat = local_stat
191 1 : return
192 : end if
193 :
194 : select type (child)
195 : type is (hsd_value)
196 : ! Convert array to space-separated string
197 2 : text = ""
198 12 : do i = 1, size(val)
199 10 : write(buffer, '(I0)') val(i)
200 18 : if (i > 1) text = text // " "
201 12 : text = text // trim(adjustl(buffer))
202 : end do
203 4 : call child%set_raw(text)
204 : end select
205 :
206 2 : if (present(stat)) stat = HSD_STAT_OK
207 :
208 9 : end subroutine hsd_set_integer_array
209 :
210 : !> Set double precision real array by path
211 14 : subroutine hsd_set_real_dp_array(table, path, val, stat)
212 : type(hsd_table), intent(inout) :: table
213 : character(len=*), intent(in) :: path
214 : real(dp), intent(in) :: val(:)
215 : integer, intent(out), optional :: stat
216 :
217 : class(hsd_node), pointer :: child
218 7 : integer :: local_stat, i
219 7 : character(len=:), allocatable :: text
220 : character(len=32) :: buffer
221 :
222 7 : call get_or_create_child(table, path, child, local_stat)
223 :
224 7 : if (local_stat /= 0) then
225 2 : if (present(stat)) stat = local_stat
226 2 : return
227 : end if
228 :
229 : select type (child)
230 : type is (hsd_value)
231 : ! Convert array to space-separated string
232 5 : text = ""
233 19 : do i = 1, size(val)
234 14 : write(buffer, '(G0)') val(i)
235 23 : if (i > 1) text = text // " "
236 19 : text = text // trim(adjustl(buffer))
237 : end do
238 10 : call child%set_raw(text)
239 : end select
240 :
241 5 : if (present(stat)) stat = HSD_STAT_OK
242 :
243 17 : end subroutine hsd_set_real_dp_array
244 :
245 : !> Set single precision real array by path
246 8 : subroutine hsd_set_real_sp_array(table, path, val, stat)
247 : type(hsd_table), intent(inout) :: table
248 : character(len=*), intent(in) :: path
249 : real(sp), intent(in) :: val(:)
250 : integer, intent(out), optional :: stat
251 :
252 4 : real(dp), allocatable :: val_dp(:)
253 :
254 4 : allocate(val_dp(size(val)))
255 14 : val_dp = real(val, dp)
256 4 : call hsd_set_real_dp_array(table, path, val_dp, stat)
257 :
258 11 : end subroutine hsd_set_real_sp_array
259 :
260 : !> Set logical array by path
261 6 : subroutine hsd_set_logical_array(table, path, val, stat)
262 : type(hsd_table), intent(inout) :: table
263 : character(len=*), intent(in) :: path
264 : logical, intent(in) :: val(:)
265 : integer, intent(out), optional :: stat
266 :
267 : class(hsd_node), pointer :: child
268 3 : integer :: local_stat, i
269 3 : character(len=:), allocatable :: text
270 :
271 3 : call get_or_create_child(table, path, child, local_stat)
272 :
273 3 : if (local_stat /= 0) then
274 1 : if (present(stat)) stat = local_stat
275 1 : return
276 : end if
277 :
278 : select type (child)
279 : type is (hsd_value)
280 : ! Convert array to space-separated string
281 2 : text = ""
282 8 : do i = 1, size(val)
283 10 : if (i > 1) text = text // " "
284 8 : if (val(i)) then
285 4 : text = text // "Yes"
286 : else
287 2 : text = text // "No"
288 : end if
289 : end do
290 4 : call child%set_raw(text)
291 : end select
292 :
293 2 : if (present(stat)) stat = HSD_STAT_OK
294 :
295 10 : end subroutine hsd_set_logical_array
296 :
297 : !> Set complex array by path
298 6 : subroutine hsd_set_complex_dp_array(table, path, val, stat)
299 : type(hsd_table), intent(inout) :: table
300 : character(len=*), intent(in) :: path
301 : complex(dp), intent(in) :: val(:)
302 : integer, intent(out), optional :: stat
303 :
304 : class(hsd_node), pointer :: child
305 3 : integer :: local_stat, i
306 3 : character(len=:), allocatable :: text
307 : character(len=64) :: buffer
308 :
309 3 : call get_or_create_child(table, path, child, local_stat)
310 :
311 3 : if (local_stat /= 0) then
312 1 : if (present(stat)) stat = local_stat
313 1 : return
314 : end if
315 :
316 : select type (child)
317 : type is (hsd_value)
318 : ! Convert array to space-separated string in a+bi format
319 2 : text = ""
320 8 : do i = 1, size(val)
321 10 : if (i > 1) text = text // " "
322 6 : if (aimag(val(i)) >= 0.0_dp) then
323 5 : write(buffer, '(G0,"+",G0,"i")') real(val(i)), aimag(val(i))
324 : else
325 1 : write(buffer, '(G0,G0,"i")') real(val(i)), aimag(val(i))
326 : end if
327 8 : text = text // trim(adjustl(buffer))
328 : end do
329 4 : call child%set_raw(text)
330 : end select
331 :
332 2 : if (present(stat)) stat = HSD_STAT_OK
333 :
334 9 : end subroutine hsd_set_complex_dp_array
335 :
336 : !> Get or create a child node by path, creating intermediate tables as needed
337 1054 : subroutine get_or_create_child(table, path, child, stat)
338 : type(hsd_table), intent(inout), target :: table
339 : character(len=*), intent(in) :: path
340 : class(hsd_node), pointer, intent(out) :: child
341 : integer, intent(out), optional :: stat
342 :
343 1054 : character(len=:), allocatable :: remaining, segment
344 : class(hsd_node), pointer :: current
345 : type(hsd_table), pointer :: current_table
346 1054 : type(hsd_table) :: new_tbl
347 1054 : type(hsd_value) :: new_val
348 1054 : integer :: sep_pos, i
349 :
350 1054 : child => null()
351 1054 : remaining = path
352 1054 : current_table => table
353 :
354 1062 : do while (len_trim(remaining) > 0)
355 : ! Get next segment
356 1061 : sep_pos = index(remaining, "/")
357 1061 : if (sep_pos > 0) then
358 21 : segment = remaining(1:sep_pos-1)
359 21 : remaining = remaining(sep_pos+1:)
360 : else
361 1040 : segment = remaining
362 1040 : remaining = ""
363 : end if
364 :
365 : ! Look for existing child
366 1061 : call current_table%get_child_by_name(segment, current, case_insensitive=.true.)
367 :
368 1061 : if (.not. associated(current)) then
369 : ! Need to create node
370 1046 : if (len_trim(remaining) > 0) then
371 : ! More path segments: create table
372 8 : call new_table(new_tbl, name=segment)
373 8 : call current_table%add_child(new_tbl)
374 : ! Get the newly added child
375 8 : do i = current_table%num_children, 1, -1
376 8 : call current_table%get_child(i, current)
377 8 : if (associated(current)) then
378 8 : if (allocated(current%name)) then
379 8 : if (to_lower(current%name) == to_lower(segment)) exit
380 : end if
381 : end if
382 : end do
383 : else
384 : ! Final segment: create value node
385 1038 : call new_value(new_val, name=segment)
386 1038 : call current_table%add_child(new_val)
387 : ! Get the newly added child
388 1038 : do i = current_table%num_children, 1, -1
389 1038 : call current_table%get_child(i, current)
390 1038 : if (associated(current)) then
391 1038 : if (allocated(current%name)) then
392 1038 : if (to_lower(current%name) == to_lower(segment)) exit
393 : end if
394 : end if
395 : end do
396 1038 : child => current
397 1038 : if (present(stat)) stat = HSD_STAT_OK
398 1038 : return
399 : end if
400 : end if
401 :
402 : ! Navigate deeper if more path remains
403 23 : if (len_trim(remaining) > 0) then
404 : select type (current)
405 : type is (hsd_table)
406 8 : current_table => current
407 : class default
408 : ! Path segment is not a table, cannot navigate
409 13 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
410 13 : return
411 : end select
412 : else
413 2 : child => current
414 2 : if (present(stat)) stat = HSD_STAT_OK
415 2 : return
416 : end if
417 : end do
418 :
419 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
420 :
421 2147 : end subroutine get_or_create_child
422 :
423 1143 : end module hsd_mutators
|
