Line data Source code
1 : !> Value operations for HSD types
2 : !>
3 : !> This submodule implements all type-bound procedures for hsd_value,
4 : !> plus private helper routines for parsing arrays, matrices, and
5 : !> complex numbers. See hsd_types.f90 for type definitions and
6 : !> interface declarations.
7 : submodule (hsd_types) hsd_value_ops
8 : implicit none (type, external)
9 :
10 : contains
11 :
12 : ! ===================================================================
13 : ! Value setters
14 : ! ===================================================================
15 :
16 : !> Set string value
17 1000 : module procedure value_set_string
18 1000 : self%value_type = VALUE_TYPE_STRING
19 1000 : self%string_value = val
20 2000 : end procedure value_set_string
21 :
22 : !> Set integer value
23 1346 : module procedure value_set_integer
24 : character(len=30) :: buf
25 1346 : write(buf, '(i0)') val
26 1346 : self%value_type = VALUE_TYPE_INTEGER
27 1346 : self%string_value = trim(buf)
28 1000 : end procedure value_set_integer
29 :
30 : !> Set real value
31 19 : module procedure value_set_real
32 : character(len=40) :: buf
33 : ! ES25.17 preserves full double precision (17 digits)
34 19 : write(buf, '(es25.17)') val
35 19 : self%value_type = VALUE_TYPE_REAL
36 19 : self%string_value = trim(adjustl(buf))
37 1346 : end procedure value_set_real
38 :
39 : !> Set logical value
40 15 : module procedure value_set_logical
41 15 : self%value_type = VALUE_TYPE_LOGICAL
42 15 : if (val) then
43 13 : self%string_value = "Yes"
44 : else
45 2 : self%string_value = "No"
46 : end if
47 19 : end procedure value_set_logical
48 :
49 : !> Set complex value
50 8 : module procedure value_set_complex
51 : character(len=80) :: buf
52 8 : write(buf, '("(", es25.17, ",", es25.17, ")")') real(val, dp), aimag(val)
53 8 : self%value_type = VALUE_TYPE_COMPLEX
54 8 : self%string_value = trim(adjustl(buf))
55 15 : end procedure value_set_complex
56 :
57 : !> Set raw text (for arrays/matrices)
58 : !>
59 : !> Detects whether the text contains multiple values (space/comma/
60 : !> newline separated) and sets VALUE_TYPE_ARRAY accordingly, so that
61 : !> hsd_is_array returns the correct result for programmatically set
62 : !> arrays.
63 101 : module procedure value_set_raw
64 :
65 101 : integer :: i, token_count
66 101 : logical :: in_token
67 :
68 : ! Quick count of whitespace/comma-separated tokens
69 101 : token_count = 0
70 101 : in_token = .false.
71 6690 : do i = 1, len(text)
72 6690 : if (is_separator(text(i:i))) then
73 856 : in_token = .false.
74 : else
75 5733 : if (.not. in_token) then
76 793 : token_count = token_count + 1
77 793 : in_token = .true.
78 : end if
79 : end if
80 : end do
81 :
82 101 : if (token_count > 1) then
83 95 : self%value_type = VALUE_TYPE_ARRAY
84 : else
85 6 : self%value_type = VALUE_TYPE_STRING
86 : end if
87 101 : self%string_value = text
88 :
89 8 : end procedure value_set_raw
90 :
91 : ! ===================================================================
92 : ! Value getters
93 : ! ===================================================================
94 :
95 : !> Get string value
96 : !>
97 : !> Returns the string representation of any typed value.
98 : !> For natively-typed values (integer, real, logical, complex), the
99 : !> value is serialized to a string on the fly.
100 70 : module procedure value_get_string
101 :
102 70 : if (allocated(self%string_value)) then
103 69 : val = self%string_value
104 69 : if (present(stat)) stat = HSD_STAT_OK
105 : else
106 1 : val = ""
107 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
108 : end if
109 :
110 101 : end procedure value_get_string
111 :
112 : !> Get integer value
113 290 : module procedure value_get_integer
114 :
115 290 : integer :: io_stat
116 :
117 290 : if (allocated(self%string_value)) then
118 289 : read(self%string_value, *, iostat=io_stat) val
119 289 : if (io_stat /= 0) then
120 3 : val = 0
121 3 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
122 : else
123 286 : if (present(stat)) stat = HSD_STAT_OK
124 : end if
125 : else
126 1 : val = 0
127 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
128 : end if
129 :
130 70 : end procedure value_get_integer
131 :
132 : !> Get real value
133 37 : module procedure value_get_real
134 :
135 37 : integer :: io_stat
136 :
137 37 : if (allocated(self%string_value)) then
138 36 : read(self%string_value, *, iostat=io_stat) val
139 36 : if (io_stat /= 0) then
140 2 : val = 0.0_dp
141 2 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
142 : else
143 34 : if (present(stat)) stat = HSD_STAT_OK
144 : end if
145 : else
146 1 : val = 0.0_dp
147 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
148 : end if
149 :
150 290 : end procedure value_get_real
151 :
152 : !> Get logical value
153 35 : module procedure value_get_logical
154 :
155 35 : character(len=:), allocatable :: lower_val
156 :
157 35 : if (allocated(self%string_value)) then
158 34 : lower_val = to_lower(trim(self%string_value))
159 25 : select case (lower_val)
160 : case ("yes", "true", ".true.", "1")
161 25 : val = .true.
162 25 : if (present(stat)) stat = HSD_STAT_OK
163 : case ("no", "false", ".false.", "0")
164 9 : val = .false.
165 9 : if (present(stat)) stat = HSD_STAT_OK
166 : case default
167 0 : val = .false.
168 34 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
169 : end select
170 : else
171 1 : val = .false.
172 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
173 : end if
174 :
175 72 : end procedure value_get_logical
176 :
177 : !> Get complex value
178 : !> Parses formats: 4.0+9.0i, 2.0-3.0i, (1.0,2.0), 5.0+2.0j
179 29 : module procedure value_get_complex
180 :
181 29 : if (allocated(self%string_value)) then
182 28 : call parse_complex(trim(self%string_value), val, stat)
183 : else
184 1 : val = (0.0_dp, 0.0_dp)
185 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
186 : end if
187 :
188 35 : end procedure value_get_complex
189 :
190 : ! ===================================================================
191 : ! Array getters
192 : ! ===================================================================
193 :
194 : !> Get integer array from raw text
195 21 : module procedure value_get_int_array
196 :
197 21 : character(len=:), allocatable :: text
198 21 : integer :: io_stat
199 :
200 : ! Get source text
201 21 : if (allocated(self%string_value)) then
202 20 : text = self%string_value
203 : else
204 1 : allocate(val(0))
205 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
206 1 : return
207 : end if
208 :
209 : ! Count and parse values
210 20 : call parse_int_array(text, val, io_stat)
211 20 : if (present(stat)) stat = io_stat
212 :
213 50 : end procedure value_get_int_array
214 :
215 : !> Get real array from raw text
216 16 : module procedure value_get_real_array
217 :
218 16 : character(len=:), allocatable :: text
219 16 : integer :: io_stat
220 :
221 : ! Get source text
222 16 : if (allocated(self%string_value)) then
223 15 : text = self%string_value
224 : else
225 1 : allocate(val(0))
226 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
227 1 : return
228 : end if
229 :
230 : ! Count and parse values
231 15 : call parse_real_array(text, val, io_stat)
232 15 : if (present(stat)) stat = io_stat
233 :
234 37 : end procedure value_get_real_array
235 :
236 : !> Get logical array from raw text
237 14 : module procedure value_get_logical_array
238 :
239 14 : character(len=:), allocatable :: text, tokens(:)
240 14 : integer :: i, n
241 :
242 14 : if (allocated(self%string_value)) then
243 13 : text = self%string_value
244 : else
245 1 : allocate(val(0))
246 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
247 1 : return
248 : end if
249 :
250 13 : call tokenize_string(text, tokens)
251 13 : n = size(tokens)
252 13 : allocate(val(n))
253 :
254 49 : do i = 1, n
255 87 : select case (to_lower(trim(tokens(i))))
256 : case ("yes")
257 21 : val(i) = .true.
258 : case ("no")
259 15 : val(i) = .false.
260 : case default
261 2 : val(i) = .false.
262 2 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
263 78 : return
264 : end select
265 : end do
266 :
267 11 : if (present(stat)) stat = HSD_STAT_OK
268 :
269 43 : end procedure value_get_logical_array
270 :
271 : !> Get complex array from raw text
272 11 : module procedure value_get_complex_array
273 :
274 11 : character(len=:), allocatable :: text
275 11 : integer :: io_stat
276 :
277 : ! Get source text
278 11 : if (allocated(self%string_value)) then
279 10 : text = self%string_value
280 : else
281 1 : allocate(val(0))
282 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
283 1 : return
284 : end if
285 :
286 : ! Count and parse values
287 10 : call parse_complex_array(text, val, io_stat)
288 10 : if (present(stat)) stat = io_stat
289 :
290 25 : end procedure value_get_complex_array
291 :
292 : !> Get string array from raw text (quoted strings preserved)
293 14 : module procedure value_get_string_array
294 :
295 14 : character(len=:), allocatable :: text
296 :
297 14 : if (allocated(self%string_value)) then
298 13 : text = self%string_value
299 : else
300 1 : allocate(character(len=1) :: val(0))
301 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
302 1 : return
303 : end if
304 :
305 13 : call tokenize_quoted_string(text, val)
306 13 : if (present(stat)) stat = HSD_STAT_OK
307 :
308 25 : end procedure value_get_string_array
309 :
310 : ! ===================================================================
311 : ! Matrix getters
312 : ! ===================================================================
313 :
314 : !> Get 2D integer matrix from raw text
315 : !> Rows separated by newlines or semicolons.
316 17 : module procedure value_get_int_matrix
317 :
318 17 : character(len=:), allocatable :: text
319 17 : integer :: io_stat
320 :
321 17 : if (allocated(self%string_value)) then
322 16 : text = self%string_value
323 : else
324 1 : allocate(val(0,0))
325 1 : nrows = 0
326 1 : ncols = 0
327 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
328 1 : return
329 : end if
330 :
331 16 : call parse_int_matrix(text, val, nrows, ncols, io_stat)
332 16 : if (present(stat)) stat = io_stat
333 :
334 31 : end procedure value_get_int_matrix
335 :
336 : !> Get 2D real matrix from raw text
337 15 : module procedure value_get_real_matrix
338 :
339 15 : character(len=:), allocatable :: text
340 15 : integer :: io_stat
341 :
342 15 : if (allocated(self%string_value)) then
343 14 : text = self%string_value
344 : else
345 1 : allocate(val(0,0))
346 1 : nrows = 0
347 1 : ncols = 0
348 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
349 1 : return
350 : end if
351 :
352 14 : call parse_real_matrix(text, val, nrows, ncols, io_stat)
353 14 : if (present(stat)) stat = io_stat
354 :
355 32 : end procedure value_get_real_matrix
356 :
357 : !> Get 2D complex matrix from raw text
358 : !> Rows separated by newlines or semicolons.
359 4 : module procedure value_get_complex_matrix
360 :
361 4 : character(len=:), allocatable :: text
362 4 : integer :: io_stat
363 :
364 4 : if (allocated(self%string_value)) then
365 4 : text = self%string_value
366 : else
367 0 : allocate(val(0,0))
368 0 : nrows = 0
369 0 : ncols = 0
370 0 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
371 0 : return
372 : end if
373 :
374 4 : call parse_complex_matrix(text, val, nrows, ncols, io_stat)
375 4 : if (present(stat)) stat = io_stat
376 :
377 19 : end procedure value_get_complex_matrix
378 :
379 : ! ===================================================================
380 : ! Private helper routines
381 : ! ===================================================================
382 :
383 : !> Check if character is a separator (whitespace, comma, semicolon)
384 24547 : pure function is_separator(ch) result(is_sep)
385 : character(len=1), intent(in) :: ch
386 : logical :: is_sep
387 : is_sep = (ch == ' ' .or. ch == char(9) .or. ch == char(10) &
388 24547 : & .or. ch == char(13) .or. ch == ',' .or. ch == ';')
389 24551 : end function is_separator
390 :
391 : !> Parse space/comma-separated integers from text
392 40 : subroutine parse_int_array(text, arr, stat)
393 : character(len=*), intent(in) :: text
394 : integer, allocatable, intent(out) :: arr(:)
395 : integer, intent(out) :: stat
396 :
397 40 : character(len=:), allocatable :: tokens(:)
398 40 : integer :: i, n, val, io_stat
399 :
400 0 : call tokenize_string(text, tokens)
401 40 : n = size(tokens)
402 :
403 40 : allocate(arr(n))
404 1674 : do i = 1, n
405 1637 : read(tokens(i), *, iostat=io_stat) val
406 1637 : if (io_stat /= 0) then
407 3 : deallocate(arr)
408 3 : allocate(arr(0))
409 3 : stat = io_stat
410 3 : return
411 : end if
412 1671 : arr(i) = val
413 : end do
414 :
415 37 : stat = 0
416 :
417 24627 : end subroutine parse_int_array
418 :
419 : !> Parse space/comma-separated reals from text
420 36 : subroutine parse_real_array(text, arr, stat)
421 : character(len=*), intent(in) :: text
422 : real(dp), allocatable, intent(out) :: arr(:)
423 : integer, intent(out) :: stat
424 :
425 36 : character(len=:), allocatable :: tokens(:)
426 36 : integer :: i, n, io_stat
427 36 : real(dp) :: val
428 :
429 0 : call tokenize_string(text, tokens)
430 36 : n = size(tokens)
431 :
432 36 : allocate(arr(n))
433 131 : do i = 1, n
434 98 : read(tokens(i), *, iostat=io_stat) val
435 98 : if (io_stat /= 0) then
436 3 : deallocate(arr)
437 3 : allocate(arr(0))
438 3 : stat = io_stat
439 3 : return
440 : end if
441 128 : arr(i) = val
442 : end do
443 :
444 33 : stat = 0
445 :
446 112 : end subroutine parse_real_array
447 :
448 : !> Tokenize string by whitespace and commas.
449 : !>
450 : !> Uses a two-pass approach (count then fill) to avoid move_alloc on
451 : !> deferred-length character arrays, which triggers an Intel ifx bug.
452 167 : subroutine tokenize_string(text, tokens)
453 : character(len=*), intent(in) :: text
454 : character(len=:), allocatable, intent(out) :: tokens(:)
455 :
456 167 : integer :: i, start, max_len, token_count
457 167 : logical :: in_token
458 :
459 : ! First pass: count tokens and find max length
460 167 : token_count = 0
461 167 : max_len = 0
462 167 : in_token = .false.
463 167 : start = 1
464 :
465 8997 : do i = 1, len(text)
466 8997 : if (is_separator(text(i:i))) then
467 1839 : if (in_token) then
468 1814 : token_count = token_count + 1
469 1814 : max_len = max(max_len, i - start)
470 1814 : in_token = .false.
471 : end if
472 : else
473 6991 : if (.not. in_token) then
474 1973 : start = i
475 1973 : in_token = .true.
476 : end if
477 : end if
478 : end do
479 :
480 167 : if (in_token) then
481 159 : token_count = token_count + 1
482 159 : max_len = max(max_len, len(text) - start + 1)
483 : end if
484 :
485 167 : if (token_count == 0 .or. max_len == 0) then
486 0 : allocate(character(len=1) :: tokens(0))
487 0 : return
488 : end if
489 :
490 : ! Allocate result array
491 167 : allocate(character(len=max_len) :: tokens(token_count))
492 :
493 : ! Second pass: extract tokens
494 167 : token_count = 0
495 167 : in_token = .false.
496 :
497 8997 : do i = 1, len(text)
498 8997 : if (is_separator(text(i:i))) then
499 1839 : if (in_token) then
500 1814 : token_count = token_count + 1
501 1814 : tokens(token_count) = text(start:i-1)
502 1814 : in_token = .false.
503 : end if
504 : else
505 6991 : if (.not. in_token) then
506 1973 : start = i
507 1973 : in_token = .true.
508 : end if
509 : end if
510 : end do
511 :
512 167 : if (in_token) then
513 159 : token_count = token_count + 1
514 159 : tokens(token_count) = text(start:len(text))
515 : end if
516 :
517 203 : end subroutine tokenize_string
518 :
519 : !> Tokenize string preserving quoted sections.
520 : !>
521 : !> Uses a two-pass approach to avoid move_alloc on deferred-length
522 : !> character arrays, which triggers an Intel ifx bug.
523 13 : subroutine tokenize_quoted_string(text, tokens)
524 : character(len=*), intent(in) :: text
525 : character(len=:), allocatable, intent(out) :: tokens(:)
526 :
527 13 : integer :: i, start, max_len, token_count, tlen
528 : character(len=1) :: quote_char
529 13 : logical :: in_token, in_quote
530 :
531 13 : tlen = len_trim(text)
532 :
533 : ! First pass: count tokens and find max length
534 13 : token_count = 0
535 13 : max_len = 0
536 13 : in_token = .false.
537 13 : in_quote = .false.
538 13 : quote_char = ' '
539 13 : start = 1
540 :
541 13 : i = 1
542 191 : do while (i <= tlen)
543 178 : if (in_quote) then
544 24 : if (text(i:i) == quote_char) then
545 5 : token_count = token_count + 1
546 5 : max_len = max(max_len, i - start - 1)
547 5 : in_quote = .false.
548 5 : in_token = .false.
549 : end if
550 154 : else if (text(i:i) == '"' .or. text(i:i) == "'") then
551 5 : quote_char = text(i:i)
552 5 : in_quote = .true.
553 5 : start = i
554 5 : in_token = .true.
555 149 : else if (is_separator(text(i:i))) then
556 23 : if (in_token) then
557 19 : token_count = token_count + 1
558 19 : max_len = max(max_len, i - start)
559 19 : in_token = .false.
560 : end if
561 : else
562 126 : if (.not. in_token) then
563 29 : start = i
564 29 : in_token = .true.
565 : end if
566 : end if
567 178 : i = i + 1
568 : end do
569 :
570 13 : if (in_token .and. .not. in_quote) then
571 10 : token_count = token_count + 1
572 10 : max_len = max(max_len, tlen - start + 1)
573 : end if
574 :
575 13 : if (token_count == 0 .or. max_len == 0) then
576 1 : allocate(character(len=1) :: tokens(0))
577 1 : return
578 : end if
579 :
580 : ! Allocate result array
581 12 : allocate(character(len=max_len) :: tokens(token_count))
582 :
583 : ! Second pass: extract tokens
584 12 : token_count = 0
585 12 : in_token = .false.
586 12 : in_quote = .false.
587 12 : quote_char = ' '
588 :
589 12 : i = 1
590 190 : do while (i <= tlen)
591 178 : if (in_quote) then
592 24 : if (text(i:i) == quote_char) then
593 5 : token_count = token_count + 1
594 5 : if (i > start + 1) then
595 4 : tokens(token_count) = text(start+1:i-1)
596 : else
597 1 : tokens(token_count) = ""
598 : end if
599 5 : in_quote = .false.
600 5 : in_token = .false.
601 : end if
602 154 : else if (text(i:i) == '"' .or. text(i:i) == "'") then
603 5 : quote_char = text(i:i)
604 5 : in_quote = .true.
605 5 : start = i
606 5 : in_token = .true.
607 149 : else if (is_separator(text(i:i))) then
608 23 : if (in_token) then
609 19 : token_count = token_count + 1
610 19 : tokens(token_count) = text(start:i-1)
611 19 : in_token = .false.
612 : end if
613 : else
614 126 : if (.not. in_token) then
615 29 : start = i
616 29 : in_token = .true.
617 : end if
618 : end if
619 178 : i = i + 1
620 : end do
621 :
622 12 : if (in_token .and. .not. in_quote) then
623 10 : token_count = token_count + 1
624 10 : tokens(token_count) = text(start:tlen)
625 : end if
626 :
627 180 : end subroutine tokenize_quoted_string
628 :
629 : !> Parse 2D integer matrix (rows by newlines or semicolons)
630 16 : subroutine parse_int_matrix(text, mat, nrows, ncols, stat)
631 : character(len=*), intent(in) :: text
632 : integer, allocatable, intent(out) :: mat(:,:)
633 : integer, intent(out) :: nrows, ncols, stat
634 :
635 16 : character(len=:), allocatable :: rows(:)
636 16 : integer, allocatable :: row_vals(:)
637 16 : integer :: i, j
638 :
639 0 : call count_matrix_dims(text, rows, nrows, ncols, stat)
640 :
641 16 : if (nrows == 0 .or. ncols == 0) then
642 2 : allocate(mat(0,0))
643 2 : nrows = 0
644 2 : ncols = 0
645 2 : stat = 0
646 2 : return
647 : end if
648 :
649 14 : if (stat /= 0) then
650 : ! Ragged matrix: return error but preserve dimension info
651 3 : allocate(mat(0,0))
652 3 : return
653 : end if
654 :
655 11 : allocate(mat(nrows, ncols))
656 105 : mat = 0
657 :
658 11 : j = 0
659 32 : do i = 1, size(rows)
660 32 : if (len_trim(rows(i)) > 0) then
661 20 : call parse_int_array(rows(i), row_vals, stat)
662 20 : if (stat /= 0) then
663 1 : deallocate(mat)
664 1 : allocate(mat(0,0))
665 1 : nrows = 0
666 1 : ncols = 0
667 1 : return
668 : end if
669 19 : if (size(row_vals) > 0) then
670 19 : j = j + 1
671 77 : mat(j, 1:size(row_vals)) = row_vals
672 : end if
673 : end if
674 : end do
675 :
676 10 : stat = 0
677 :
678 45 : end subroutine parse_int_matrix
679 :
680 : !> Parse 2D real matrix
681 14 : subroutine parse_real_matrix(text, mat, nrows, ncols, stat)
682 : character(len=*), intent(in) :: text
683 : real(dp), allocatable, intent(out) :: mat(:,:)
684 : integer, intent(out) :: nrows, ncols, stat
685 :
686 14 : character(len=:), allocatable :: rows(:)
687 14 : real(dp), allocatable :: row_vals(:)
688 14 : integer :: i, j
689 :
690 0 : call count_matrix_dims(text, rows, nrows, ncols, stat)
691 :
692 14 : if (nrows == 0 .or. ncols == 0) then
693 1 : allocate(mat(0,0))
694 1 : nrows = 0
695 1 : ncols = 0
696 1 : stat = 0
697 1 : return
698 : end if
699 :
700 13 : if (stat /= 0) then
701 : ! Ragged matrix: return error but preserve dimension info
702 2 : allocate(mat(0,0))
703 2 : return
704 : end if
705 :
706 11 : allocate(mat(nrows, ncols))
707 88 : mat = 0.0_dp
708 :
709 11 : j = 0
710 31 : do i = 1, size(rows)
711 31 : if (len_trim(rows(i)) > 0) then
712 21 : call parse_real_array(rows(i), row_vals, stat)
713 21 : if (stat /= 0) then
714 1 : deallocate(mat)
715 1 : allocate(mat(0,0))
716 1 : nrows = 0
717 1 : ncols = 0
718 1 : return
719 : end if
720 20 : if (size(row_vals) > 0) then
721 20 : j = j + 1
722 68 : mat(j, 1:size(row_vals)) = row_vals
723 : end if
724 : end if
725 : end do
726 :
727 10 : stat = 0
728 :
729 44 : end subroutine parse_real_matrix
730 :
731 : !> Count matrix dimensions from text (rows by newlines/semicolons)
732 : !>
733 : !> Shared helper for parse_int_matrix and parse_real_matrix.
734 : !> Splits text into rows, counts non-empty rows, and validates
735 : !> that all rows have the same number of columns.
736 : !>
737 : !> @param[in] text Raw text to parse
738 : !> @param[out] rows Rows split by newlines (for caller to parse)
739 : !> @param[out] nrows Number of non-empty rows
740 : !> @param[out] ncols Number of columns (from first row)
741 : !> @param[out] stat 0 on success, HSD_STAT_TYPE_ERROR on ragged
742 34 : subroutine count_matrix_dims(text, rows, nrows, ncols, stat)
743 : character(len=*), intent(in) :: text
744 : character(len=:), allocatable, intent(out) :: rows(:)
745 : integer, intent(out) :: nrows, ncols, stat
746 :
747 34 : character(len=:), allocatable :: tokens(:)
748 34 : integer :: i, row_count, col_count, first_cols
749 :
750 0 : call split_by_newlines(text, rows)
751 34 : row_count = size(rows)
752 :
753 34 : nrows = 0
754 34 : ncols = 0
755 34 : first_cols = -1
756 34 : stat = 0
757 :
758 99 : do i = 1, row_count
759 99 : if (len_trim(rows(i)) > 0) then
760 60 : call tokenize_string(rows(i), tokens)
761 60 : col_count = size(tokens)
762 60 : if (col_count > 0) then
763 60 : nrows = nrows + 1
764 60 : if (first_cols < 0) then
765 31 : first_cols = col_count
766 31 : ncols = col_count
767 29 : else if (col_count /= first_cols) then
768 : ! Ragged matrix: flag error but preserve dimension info
769 6 : ncols = max(ncols, col_count)
770 6 : stat = HSD_STAT_TYPE_ERROR
771 : end if
772 : end if
773 : end if
774 : end do
775 :
776 48 : end subroutine count_matrix_dims
777 :
778 : !> Split text by newlines or semicolons.
779 : !>
780 : !> Uses a two-pass approach to avoid move_alloc on deferred-length
781 : !> character arrays, which triggers an Intel ifx bug.
782 34 : subroutine split_by_newlines(text, lines)
783 : character(len=*), intent(in) :: text
784 : character(len=:), allocatable, intent(out) :: lines(:)
785 :
786 34 : integer :: i, start, line_count, max_len, tlen
787 :
788 34 : tlen = len(text)
789 :
790 : ! First pass: count lines and find max length
791 34 : line_count = 0
792 34 : max_len = 0
793 34 : start = 1
794 :
795 898 : do i = 1, tlen
796 898 : if (text(i:i) == char(10) .or. text(i:i) == ';') then
797 31 : line_count = line_count + 1
798 31 : max_len = max(max_len, i - start)
799 31 : start = i + 1
800 : end if
801 : end do
802 :
803 34 : if (start <= tlen) then
804 33 : line_count = line_count + 1
805 33 : max_len = max(max_len, tlen - start + 1)
806 : end if
807 :
808 34 : if (line_count == 0 .or. max_len == 0) then
809 1 : allocate(character(len=max(1, len(text))) :: lines(1))
810 1 : lines(1) = text
811 1 : return
812 : end if
813 :
814 : ! Allocate result array
815 33 : allocate(character(len=max_len) :: lines(line_count))
816 :
817 : ! Second pass: extract lines
818 33 : line_count = 0
819 33 : start = 1
820 :
821 897 : do i = 1, tlen
822 897 : if (text(i:i) == char(10) .or. text(i:i) == ';') then
823 31 : line_count = line_count + 1
824 31 : if (i > start) then
825 29 : lines(line_count) = text(start:i-1)
826 : else
827 2 : lines(line_count) = ""
828 : end if
829 31 : start = i + 1
830 : end if
831 : end do
832 :
833 33 : if (start <= tlen) then
834 33 : line_count = line_count + 1
835 33 : lines(line_count) = text(start:tlen)
836 : end if
837 :
838 68 : end subroutine split_by_newlines
839 :
840 : !> Parse 2D complex matrix
841 4 : subroutine parse_complex_matrix(text, mat, nrows, ncols, stat)
842 : character(len=*), intent(in) :: text
843 : complex(dp), allocatable, intent(out) :: mat(:,:)
844 : integer, intent(out) :: nrows, ncols, stat
845 :
846 4 : character(len=:), allocatable :: rows(:)
847 4 : complex(dp), allocatable :: row_vals(:)
848 4 : integer :: i, j
849 :
850 0 : call count_matrix_dims(text, rows, nrows, ncols, stat)
851 :
852 4 : if (nrows == 0 .or. ncols == 0) then
853 0 : allocate(mat(0,0))
854 0 : nrows = 0
855 0 : ncols = 0
856 0 : stat = 0
857 0 : return
858 : end if
859 :
860 4 : if (stat /= 0) then
861 : ! Ragged matrix: return error but preserve dimension info
862 0 : allocate(mat(0,0))
863 0 : return
864 : end if
865 :
866 4 : allocate(mat(nrows, ncols))
867 34 : mat = (0.0_dp, 0.0_dp)
868 :
869 4 : j = 0
870 12 : do i = 1, size(rows)
871 12 : if (len_trim(rows(i)) > 0) then
872 8 : call parse_complex_array(rows(i), row_vals, stat)
873 8 : if (stat /= 0) then
874 0 : deallocate(mat)
875 0 : allocate(mat(0,0))
876 0 : nrows = 0
877 0 : ncols = 0
878 0 : return
879 : end if
880 8 : if (size(row_vals) > 0) then
881 8 : j = j + 1
882 28 : mat(j, 1:size(row_vals)) = row_vals
883 : end if
884 : end if
885 : end do
886 :
887 4 : stat = 0
888 :
889 42 : end subroutine parse_complex_matrix
890 :
891 : !> Parse a single complex number from string
892 : !> Supports: 4.0+9.0i, 2.0-3.0i, (1.0,2.0), 5.0+2.0j, 3.5,
893 : !> pure imaginary 2.0i
894 69 : subroutine parse_complex(str, val, stat)
895 : character(len=*), intent(in) :: str
896 : complex(dp), intent(out) :: val
897 : integer, intent(out), optional :: stat
898 :
899 69 : character(len=:), allocatable :: work
900 69 : integer :: i, sign_pos, io_stat
901 69 : real(dp) :: re, im
902 : character(len=1) :: ch
903 :
904 69 : work = adjustl(trim(str))
905 :
906 : ! Handle empty string
907 69 : if (len_trim(work) == 0) then
908 1 : val = (0.0_dp, 0.0_dp)
909 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
910 1 : return
911 : end if
912 :
913 : ! Handle Fortran-style (re,im) format
914 68 : if (work(1:1) == '(') then
915 8 : i = index(work, ')')
916 8 : if (i > 2) then
917 8 : work = work(2:i-1)
918 8 : i = index(work, ',')
919 8 : if (i > 0) then
920 8 : read(work(1:i-1), *, iostat=io_stat) re
921 8 : if (io_stat /= 0) then
922 1 : val = (0.0_dp, 0.0_dp)
923 1 : if (present(stat)) stat = io_stat
924 1 : return
925 : end if
926 7 : read(work(i+1:), *, iostat=io_stat) im
927 7 : if (io_stat /= 0) then
928 2 : val = (0.0_dp, 0.0_dp)
929 2 : if (present(stat)) stat = io_stat
930 2 : return
931 : end if
932 5 : val = cmplx(re, im, dp)
933 5 : if (present(stat)) stat = HSD_STAT_OK
934 5 : return
935 : end if
936 : end if
937 : end if
938 :
939 : ! Handle a+bi or a-bi format (also handles j instead of i)
940 : ! Find the + or - that separates real and imaginary parts
941 : ! (must skip the first char and any exponent signs)
942 60 : sign_pos = 0
943 670 : do i = 2, len_trim(work)
944 610 : ch = work(i:i)
945 670 : if ((ch == '+' .or. ch == '-')) then
946 : ! Make sure this isn't part of an exponent
947 51 : if (i > 1) then
948 : if (work(i-1:i-1) /= 'e' &
949 : & .and. work(i-1:i-1) /= 'E' &
950 : & .and. work(i-1:i-1) /= 'd' &
951 51 : & .and. work(i-1:i-1) /= 'D') then
952 51 : sign_pos = i
953 : end if
954 : end if
955 : end if
956 : end do
957 :
958 : ! Check if last character is 'i' or 'j' (imaginary marker)
959 60 : ch = work(len_trim(work):len_trim(work))
960 : if (ch == 'i' .or. ch == 'I' &
961 60 : & .or. ch == 'j' .or. ch == 'J') then
962 55 : if (sign_pos > 0) then
963 : ! Format: a+bi or a-bi
964 51 : read(work(1:sign_pos-1), *, iostat=io_stat) re
965 51 : if (io_stat /= 0) then
966 1 : val = (0.0_dp, 0.0_dp)
967 1 : if (present(stat)) stat = io_stat
968 1 : return
969 : end if
970 50 : read(work(sign_pos:len_trim(work)-1), *, &
971 100 : & iostat=io_stat) im
972 50 : if (io_stat /= 0) then
973 2 : val = (0.0_dp, 0.0_dp)
974 2 : if (present(stat)) stat = io_stat
975 2 : return
976 : end if
977 48 : val = cmplx(re, im, dp)
978 48 : if (present(stat)) stat = HSD_STAT_OK
979 48 : return
980 : else
981 : ! Pure imaginary: bi
982 4 : read(work(1:len_trim(work)-1), *, iostat=io_stat) im
983 4 : if (io_stat /= 0) then
984 1 : val = (0.0_dp, 0.0_dp)
985 1 : if (present(stat)) stat = io_stat
986 1 : return
987 : end if
988 3 : val = cmplx(0.0_dp, im, dp)
989 3 : if (present(stat)) stat = HSD_STAT_OK
990 3 : return
991 : end if
992 : else
993 : ! Pure real number
994 5 : read(work, *, iostat=io_stat) re
995 5 : if (io_stat /= 0) then
996 3 : val = (0.0_dp, 0.0_dp)
997 3 : if (present(stat)) stat = io_stat
998 3 : return
999 : end if
1000 2 : val = cmplx(re, 0.0_dp, dp)
1001 2 : if (present(stat)) stat = HSD_STAT_OK
1002 : end if
1003 :
1004 73 : end subroutine parse_complex
1005 :
1006 : !> Parse an array of complex numbers from text
1007 18 : subroutine parse_complex_array(text, arr, stat)
1008 : character(len=*), intent(in) :: text
1009 : complex(dp), allocatable, intent(out) :: arr(:)
1010 : integer, intent(out) :: stat
1011 :
1012 18 : character(len=:), allocatable :: tokens(:)
1013 18 : integer :: i, n, io_stat
1014 18 : complex(dp) :: val
1015 :
1016 0 : call tokenize_string(text, tokens)
1017 18 : n = size(tokens)
1018 :
1019 18 : allocate(arr(n))
1020 57 : do i = 1, n
1021 41 : call parse_complex(tokens(i), val, io_stat)
1022 41 : if (io_stat /= 0) then
1023 2 : deallocate(arr)
1024 2 : allocate(arr(0))
1025 2 : stat = io_stat
1026 2 : return
1027 : end if
1028 96 : arr(i) = val
1029 : end do
1030 :
1031 16 : stat = 0
1032 :
1033 105 : end subroutine parse_complex_array
1034 :
1035 8 : end submodule hsd_value_ops
|
