Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This file contains the implementation details of the routines for converting a logical or number of different types and kinds to char.
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, Saturday 9:44 PM, August 21, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !> The maximum possible length of the string output from the functions under the generic interface `getStr`.
28 : !> Note that `STRLENMAX = 127` is very generous given that,
29 : !> + The maximum length of a complex of kind `real128` including signs, exponentiation, comma, and parentheses is `93` characters.
30 : !> `(-1.189731495357231765085759326628007016E+4932,-1.189731495357231765085759326628007016E+4932)`
31 : !> + The maximum length of a real of kind `real128` including signs and exponentiation is `44` characters.
32 : !> `-1.18973149535723176508575932662800702E+4932`
33 : !> + The maximum length of an integer of kind `int64` including signs `20` characters.
34 : !> `-9223372036854775807`
35 : character(*), parameter :: SEP = ", "
36 : integer(IK) , parameter :: SEPLEN = len(SEP, kind = IK)
37 : integer(IK) , parameter :: STRLENMAX = 127_IK
38 : #if CK_ENABLED
39 : character(*, SK), parameter :: FORMAT_SIGNED = SK_"(*('(',sp,g0,'"//SEP//SK_"',g0,')',:,'"//SEP//SK_"'))"
40 : character(*, SK), parameter :: FORMAT_UNSIGNED = SK_"(*('(',g0,'"//SEP//SK_"',g0,')',:,'"//SEP//SK_"'))"
41 : #elif IK_ENABLED || RK_ENABLED
42 : character(*, SK), parameter :: FORMAT_SIGNED = SK_"(*(sp,g0,:,'"//SEP//SK_"'))"
43 : character(*, SK), parameter :: FORMAT_UNSIGNED = SK_"(*(g0,:,'"//SEP//SK_"'))"
44 : #endif
45 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
46 : #if getStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D0_ENABLED
47 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
48 :
49 0 : CHECK_ASSERTION(__LINE__, allocated(val%val), SK_"@getStr(): The condition `allocated(val%val)` must hold.")
50 0 : if (present(length)) then
51 0 : call setResized(str, length)
52 0 : if (present(format)) then
53 0 : write(str, format) val%val
54 : else
55 0 : CHECK_ASSERTION(__LINE__, len(val%val, IK) <= length, SK_"@getStr(): The condition `len(val%val) <= length` must hold. len(val%val), length = "//getStr([len(val%val, IK), length]))
56 0 : str(1: len(val%val, IK)) = val%val
57 : end if
58 0 : elseif (present(format)) then
59 : block
60 : integer(IK) :: iostat
61 : character(127, SK) :: iomsg
62 0 : do
63 0 : write(str, format, iostat = iostat, iomsg = iomsg) val%val
64 0 : if (iostat == 0_IK) then
65 : exit
66 0 : elseif (is_iostat_eor(iostat)) then
67 0 : call setResized(str)
68 : cycle
69 : else
70 : error stop MODULE_NAME//SK_"@getStr(): "//trim(iomsg) ! LCOV_EXCL_LINE
71 : end if
72 : end do
73 : end block
74 0 : str = trim(str)
75 : else
76 0 : str = val%val
77 : end if
78 :
79 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
80 : #elif setStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D0_ENABLED
81 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
82 :
83 0 : CHECK_ASSERTION(__LINE__, allocated(val%val), SK_"@setStr(): The condition `allocated(val%val)` must hold.")
84 0 : if (present(format)) then
85 0 : write(str, format) val%val
86 : else
87 0 : CHECK_ASSERTION(__LINE__, len(val%val, IK) <= len(str, IK), SK_"@setStr(): The condition `len(val%val) <= len(str)` must hold. len(val%val), len(str) = "//getStr([len(val%val, IK), len(str, IK)]))
88 0 : str = val%val
89 : end if
90 0 : length = len_trim(str, IK)
91 :
92 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
93 : #elif getStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D1_ENABLED
94 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
95 :
96 : integer(IK) :: i, lenstr
97 93 : CHECK_ASSERTION(__LINE__, all([(allocated(val(i)%val), i = 1, size(val, 1, IK))]), SK_"@getStr(): The condition `all([(allocated(val(i)%val), i = 1, size(val, 1, IK))])` must hold.")
98 13 : if (present(length)) then
99 0 : call setResized(str, length)
100 0 : if (present(format)) then
101 0 : write(str, format) (val(i)%val, i = 1, size(val, 1, IK))
102 : else
103 0 : if (0_IK < size(val, kind = IK)) then
104 0 : str = val(1)%val
105 0 : do i = 2, size(val, 1, IK)
106 0 : str = str//SEP//val(i)%val
107 : end do
108 : else
109 0 : str = SKC_""
110 : end if
111 0 : CHECK_ASSERTION(__LINE__, len(str, IK) <= length, SK_"@getStr(): The condition `len(str) <= length` must hold. len(str), length = "//getStr([len(str, IK), length]))
112 : end if
113 13 : elseif (present(format)) then
114 : block
115 : integer :: iostat
116 : character(127, SK) :: iomsg
117 13 : lenstr = -SEPLEN
118 53 : do i = 1, size(val, 1, IK)
119 53 : lenstr = lenstr + SEPLEN + len(val(i)%val, IK)
120 : end do
121 13 : call setResized(str, lenstr)
122 0 : do
123 53 : write(str, format, iostat = iostat, iomsg = iomsg) (val(i)%val, i = 1, size(val, 1, IK))
124 13 : if (iostat == 0_IK) then
125 : exit
126 0 : elseif (is_iostat_eor(iostat)) then
127 0 : call setResized(str)
128 : cycle
129 : else
130 : error stop MODULE_NAME//SK_"@getStr(): "//trim(iomsg) ! LCOV_EXCL_LINE
131 : end if
132 : end do
133 : end block
134 13 : str = trim(str)
135 : else
136 0 : if (0_IK < size(val, kind = IK)) then
137 0 : str = val(1)%val
138 0 : do i = 2, size(val, 1, IK)
139 0 : str = str//SEP//val(i)%val
140 : end do
141 : else
142 0 : str = SKC_""
143 : end if
144 : end if
145 :
146 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
147 : #elif setStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D1_ENABLED
148 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
149 :
150 : integer(IK) :: i
151 0 : CHECK_ASSERTION(__LINE__, all([(allocated(val(i)%val), i = 1, size(val, 1, IK))]), SK_"@getStr(): The condition `all([(allocated(val(i)%val), i = 1, size(val, 1, IK))])` must hold.")
152 0 : if (present(format)) then
153 0 : write(str, format) (val(i)%val, i = 1, size(val, 1, IK))
154 : else
155 0 : write(str, "(*(a,:,'"//SEP//"'))") (val(i)%val, i = 1, size(val, 1, IK))
156 : end if
157 0 : length = len_trim(str, IK)
158 :
159 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
160 : #elif getStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D2_ENABLED
161 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
162 :
163 : integer(IK) :: i, j, lenstr
164 0 : CHECK_ASSERTION(__LINE__, all([((allocated(val(i,j)%val), i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))]), SK_"@getStr(): The condition `all([((allocated(val(i,j)%val), i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))])` must hold.")
165 0 : if (present(length)) then
166 0 : call setResized(str, length)
167 0 : if (present(format)) then
168 0 : write(str, format) ((val(i,j)%val, i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))
169 : else
170 0 : if (0_IK < size(val, kind = IK)) then
171 0 : str = val(1,1)%val
172 0 : do i = 2, size(val, 1, IK)
173 0 : str = str//SEP//val(i,1)%val
174 : end do
175 0 : do j = 2, size(val, 2, IK)
176 0 : do i = 2, size(val, 1, IK)
177 0 : str = str//SEP//val(i,j)%val
178 : end do
179 : end do
180 : else
181 0 : str = SKC_""
182 : end if
183 0 : CHECK_ASSERTION(__LINE__, len(str, IK) <= length, SK_"@getStr(): The condition `len(str) <= length` must hold. len(str), length = "//getStr([len(str, IK), length]))
184 : end if
185 0 : elseif (present(format)) then
186 : block
187 : integer :: iostat
188 : character(127, SK) :: iomsg
189 0 : lenstr = -SEPLEN
190 0 : do j = 1, size(val, 2, IK)
191 0 : do i = 1, size(val, 1, IK)
192 0 : lenstr = lenstr + SEPLEN + len(val(i,j)%val, IK)
193 : end do
194 : end do
195 0 : call setResized(str, lenstr)
196 0 : do
197 0 : write(str, format, iostat = iostat, iomsg = iomsg) ((val(i,j)%val, i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))
198 0 : if (iostat == 0_IK) then
199 : exit
200 0 : elseif (is_iostat_eor(iostat)) then
201 0 : call setResized(str)
202 : cycle
203 : else
204 : error stop MODULE_NAME//SK_"@getStr(): "//trim(iomsg) ! LCOV_EXCL_LINE
205 : end if
206 : end do
207 : end block
208 0 : str = trim(str)
209 : else
210 0 : if (0_IK < size(val, kind = IK)) then
211 0 : str = val(1,1)%val
212 0 : do i = 2, size(val, 1, IK)
213 0 : str = str//SEP//val(i,1)%val
214 : end do
215 0 : do j = 2, size(val, 2, IK)
216 0 : do i = 2, size(val, 1, IK)
217 0 : str = str//SEP//val(i,j)%val
218 : end do
219 : end do
220 : else
221 0 : str = SKC_""
222 : end if
223 : end if
224 :
225 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
226 : #elif setStr_ENABLED && (BSSK_ENABLED || PSSK_ENABLED) && D2_ENABLED
227 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
228 :
229 : integer(IK) :: i, j
230 0 : CHECK_ASSERTION(__LINE__, all([((allocated(val(i,j)%val), i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))]), SK_"@getStr(): The condition `all([((allocated(val(i,j)%val), i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))])` must hold.")
231 0 : if (present(format)) then
232 0 : if (0_IK < size(val, kind = IK)) write(str, format) ((val(i, j)%val, i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))
233 : else
234 0 : if (0_IK < size(val, kind = IK)) write(str, "(*(a,:,'"//SEP//"'))") ((val(i, j)%val, i = 1, size(val, 1, IK)), j = 1, size(val, 2, IK))
235 : end if
236 0 : length = len_trim(str, IK)
237 :
238 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
239 : #elif SK_ENABLED || IK_ENABLED || LK_ENABLED || CK_ENABLED || RK_ENABLED
240 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
241 :
242 : #if getStr_ENABLED
243 : #define SET_LENGTH(i)
244 : #define CHECK_STR_LEN(LINE)
245 : #elif setStr_ENABLED
246 : #define SET_LENGTH(i) length = i
247 : #define CHECK_STR_LEN(LINE) \
248 : CHECK_ASSERTION(LINE, len(str, IK) >= length, SK_"@setStr(): The condition `len(str, IK) >= length` must hold. len(str, IK), length = "//getStr([len(str, IK), length]))
249 : #else
250 : #error "Unrecognized interface."
251 : #endif
252 365250619 : if (present(format)) then
253 :
254 : #if getStr_ENABLED
255 4848947 : if (present(length)) then
256 4842833 : allocate(character(length,SKO) :: str)
257 4842833 : write(str, format) val
258 : else
259 : #if SK_ENABLED && D0_ENABLED
260 : ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
261 2517 : allocate(character(len(val, kind = IK),SKO) :: str)
262 : #elif SK_ENABLED && (D1_ENABLED || D2_ENABLED)
263 : ! extra 2 allows for possible separator.
264 : ! Fortran standard: Upon running the write statement,
265 : ! the untouched section of the record is padded with blanks.
266 0 : allocate(character(size(val, kind = IK) * (len(val, kind = IK) + 2_IK),SKO) :: str)
267 : #elif (IK_ENABLED || LK_ENABLED || RK_ENABLED || CK_ENABLED) && D0_ENABLED
268 : ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
269 3577 : allocate(character(STRLENMAX,SKO) :: str)
270 : #elif (IK_ENABLED || LK_ENABLED || RK_ENABLED || CK_ENABLED) && (D1_ENABLED || D2_ENABLED)
271 : ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
272 20 : allocate(character(size(val, kind = IK) * STRLENMAX,SKO) :: str)
273 : #else
274 : #error "Unrecognized interface."
275 : #endif
276 2537 : if (len(str, IK) > 0_IK) then
277 : block
278 : character(127, SK) :: iomsg
279 : integer(IK) :: iostat
280 0 : do
281 6114 : write(str, format, iostat = iostat, iomsg = iomsg) val
282 6114 : if (iostat == 0_IK) then
283 : exit
284 0 : elseif (is_iostat_eor(iostat)) then
285 0 : call setResized(str)
286 : cycle
287 : else
288 : error stop MODULE_NAME//SK_"@getStr(): "//trim(iomsg) ! LCOV_EXCL_LINE
289 : end if
290 : end do
291 : end block
292 6114 : str = trim(str)
293 : end if
294 : end if
295 : #elif setStr_ENABLED
296 2 : length = len(str, IK)
297 2 : if (length > 0_IK) then
298 2 : write(str, format) val
299 2006 : do
300 2008 : if (length == 0_IK) exit
301 2008 : if (str(length:length) /= SKO_" ") exit
302 2008 : length = length - 1_IK
303 : end do
304 : end if
305 : #else
306 : #error "Unrecognized interface."
307 : #endif
308 4848949 : return
309 :
310 : else
311 :
312 : !%%%%%%%%%
313 : #if SK_ENABLED
314 : !%%%%%%%%%
315 :
316 : #if D0_ENABLED && getStr_ENABLED
317 786758 : if (present(length)) then
318 0 : allocate(character(length,SKO) :: str)
319 0 : CHECK_ASSERTION(__LINE__, length >= len(val, IK), SK_"@getStr(): The condition `length >= len(val)` must hold. length, len(val) = "//getStr([length, len(val, IK)]))
320 0 : str(1:len(val, IK)) = val
321 0 : return
322 : end if
323 786758 : str = trim(val)
324 : #elif D0_ENABLED && setStr_ENABLED
325 3 : SET_LENGTH(len_trim(val, IK)) ! fpp
326 3 : str(1:length) = val(1:length)
327 9 : CHECK_STR_LEN(__LINE__) ! fpp
328 : #elif D1_ENABLED || D2_ENABLED
329 1249437 : if (size(val, kind = IK) > 0_IK) then
330 1249283 : call setStrFromStr(val, str, length)
331 6 : CHECK_STR_LEN(__LINE__) ! fpp
332 : else
333 : #if getStr_ENABLED
334 154 : if (present(length)) then
335 0 : str = repeat(SKO_" ", length)
336 0 : return
337 : end if
338 : #elif !setStr_ENABLED
339 : #error "Unrecognized interface."
340 : #endif
341 0 : SET_LENGTH(0_IK) ! fpp
342 154 : str = SKO_""
343 : end if
344 6 : CHECK_STR_LEN(__LINE__) ! fpp
345 : #else
346 : #error "Unrecognized interface."
347 : #endif
348 :
349 : !%%%%%%%%%
350 : #elif LK_ENABLED
351 : !%%%%%%%%%
352 :
353 : #if D0_ENABLED
354 : #if getStr_ENABLED
355 158073 : if (present(length)) then
356 0 : allocate(character(length,SKO) :: str)
357 0 : if (val) then
358 0 : CHECK_ASSERTION(__LINE__, length >= 4_IK, SK_"@getStr(): The condition `length >= 4_IK` must hold. length = "//getStr(length))
359 0 : str = SKO_"TRUE"
360 : else
361 0 : CHECK_ASSERTION(__LINE__, length >= 5_IK, SK_"@getStr(): The condition `length >= 5_IK` must hold. length = "//getStr(length))
362 0 : str = SKO_"FALSE"
363 : end if
364 0 : return
365 : end if
366 : #elif !setStr_ENABLED
367 : #error "Unrecognized interface."
368 : #endif
369 158075 : if (val) then
370 1 : SET_LENGTH(4_IK) ! fpp
371 103173 : str = SKO_"TRUE"
372 : else
373 1 : SET_LENGTH(5_IK) ! fpp
374 54902 : str = SKO_"FALSE"
375 : end if
376 6 : CHECK_STR_LEN(__LINE__) ! fpp
377 : #elif D1_ENABLED || D2_ENABLED
378 798147 : if (size(val, kind = IK) > 1_IK) then
379 773053 : call setStrFromLogical(val, str, length)
380 25094 : elseif (size(val, kind = IK) == 1_IK) then
381 37738 : if (any(val)) then
382 0 : SET_LENGTH(4_IK) ! fpp
383 11080 : str = SKO_"TRUE"
384 : else
385 0 : SET_LENGTH(5_IK) ! fpp
386 13329 : str = SKO_"FALSE"
387 : end if
388 : else
389 0 : SET_LENGTH(0_IK) ! fpp
390 685 : str = SKO_""
391 : end if
392 0 : CHECK_STR_LEN(__LINE__) ! fpp
393 : #else
394 : #error "Unrecognized interface."
395 : #endif
396 :
397 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
398 : #elif IK_ENABLED || CK_ENABLED || RK_ENABLED
399 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
400 :
401 : #if getStr_ENABLED
402 178842040 : if (present(length)) then
403 76 : allocate(character(length,SKO) :: str)
404 : else
405 : #if D0_ENABLED
406 : ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
407 79543008 : allocate(character(STRLENMAX,SKO) :: str)
408 : #elif D1_ENABLED || D2_ENABLED
409 : ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
410 99298956 : allocate(character(STRLENMAX * size(val, kind = IK),SKO) :: str)
411 : #else
412 : #error "Unrecognized interface."
413 : #endif
414 : end if
415 : #elif !setStr_ENABLED
416 : #error "Unrecognized interface."
417 : #endif
418 178842050 : if (present(signed)) then
419 151 : if (signed) then
420 151 : write(str, FORMAT_SIGNED) val
421 : #if getStr_ENABLED
422 148 : if (.not. present(length)) str = trim(str) ! Fortran standard: char is by default left-adjusted when dealing with internal files.
423 : #elif setStr_ENABLED
424 3 : length = len(str, IK)
425 3 : if (length == 0_IK) return
426 2868 : do
427 2871 : if (str(length : length) /= SKO_" ") exit
428 2868 : length = length - 1_IK
429 : end do
430 9 : CHECK_STR_LEN(__LINE__) ! fpp
431 : #endif
432 151 : return
433 : end if
434 : end if
435 178841899 : if (len(str, IK) > 0_IK) then
436 178826106 : write(str, FORMAT_UNSIGNED) val
437 : #if getStr_ENABLED
438 : ! Fortran standard: char is by default left-adjusted when dealing with internal files.
439 178826099 : if (.not. present(length)) str = trim(str)
440 : #elif setStr_ENABLED
441 7 : length = len(str, IK)
442 : if (length == 0_IK) return
443 6958 : do
444 6965 : if (str(length : length) /= SKO_" ") exit
445 6958 : length = length - 1_IK
446 : end do
447 21 : CHECK_STR_LEN(__LINE__) ! fpp
448 : #endif
449 : else
450 0 : SET_LENGTH(0_IK) ! fpp
451 : end if
452 : #else
453 : #error "Unrecognized interface."
454 : #endif
455 :
456 : end if
457 :
458 : contains
459 :
460 : #if SK_ENABLED && (D1_ENABLED || D2_ENABLED)
461 1249283 : PURE subroutine setStrFromStr(ValVec, str, length)
462 : #if getStr_ENABLED
463 : integer(IK) :: endpos
464 : integer(IK) , intent(in) , optional :: length
465 : character(:,SKO), intent(out) , allocatable :: str
466 : #elif setStr_ENABLED
467 : #define endpos length
468 : character(*,SKO), intent(out) :: str
469 : integer(IK) , intent(out) :: length
470 : #elif !setStr_ENABLED
471 : #error "Unrecognized interface."
472 : #endif
473 : character(*,SKC), intent(in) :: ValVec(*)
474 : integer(IK) :: i, iend, sizeVal, lenVal, startpos
475 1249283 : sizeVal = size(val, kind = IK)
476 1249283 : lenVal = len(val, kind = IK)
477 : #if getStr_ENABLED
478 1249281 : if (present(length)) then
479 0 : allocate(character(length,SKO) :: str) ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
480 : else
481 1249281 : allocate(character(sizeVal * (lenVal + SEPLEN) - SEPLEN,SKO) :: str) ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
482 : end if
483 : #endif
484 1249397 : do endpos = lenVal, 1_IK, -1_IK
485 1249397 : if (ValVec(1)(endpos:endpos) /= SKC_" ") exit
486 : end do
487 1249283 : str(1:endpos) = ValVec(1)(1:endpos)
488 2737892 : do i = 2_IK, sizeVal
489 1488609 : startpos = endpos + 1_IK
490 1488609 : endpos = endpos + SEPLEN
491 1488609 : str(startpos : endpos) = SEP
492 1490518 : do iend = lenVal, 1_IK, -1_IK
493 1490518 : if (ValVec(i)(iend:iend) /= SKC_" ") exit
494 : end do
495 1488609 : startpos = endpos + 1_IK
496 1488609 : endpos = endpos + iend
497 2737892 : str(startpos:endpos) = ValVec(i)(1:iend)
498 : end do
499 : !#if getStr_ENABLED
500 : ! ! This condition cannot be readily verified because the right blanks are trimmed, leading `endpos` values are smaller than the expected value.
501 : ! ! Nevertheless, any length error is typically well captured by Intel and gfortran compilers.
502 : ! check_assertion(__LINE__, endpos == sizeVal * (lenVal + SEPLEN) - SEPLEN .or. (present(length) .and. endpos >= sizeVal * (lenVal + SEPLEN) - SEPLEN), \
503 : ! SK_"@getStr(): The condition `length >= sizeVal * (lenVal + SEPLEN) - SEPLEN` must hold. length, ... = "//getStr([endpos, sizeVal * (lenVal + SEPLEN) - SEPLEN]))
504 : ! str = str(1:endpos)
505 : !#endif
506 1249283 : end subroutine
507 : #elif LK_ENABLED && (D1_ENABLED || D2_ENABLED)
508 773053 : PURE subroutine setStrFromLogical(ValVec, str, length)
509 : #if getStr_ENABLED
510 : integer(IK) :: endpos
511 : integer(IK) , intent(in) , optional :: length
512 : character(:,SKO), intent(out) , allocatable :: str
513 : #elif setStr_ENABLED
514 : #define endpos length
515 : character(*,SKO), intent(out) :: str
516 : integer(IK) , intent(out) :: length
517 : #elif !setStr_ENABLED
518 : #error "Unrecognized interface."
519 : #endif
520 : logical(LKC) , intent(in) :: ValVec(*)
521 : integer(IK) :: lenStr, sizeVal, i, startpos
522 773053 : sizeVal = size(val, kind = IK)
523 3449352 : lenStr = count(val, kind = IK)
524 773053 : lenStr = lenStr * (4_IK + SEPLEN) + (sizeVal - lenStr) * (5_IK + SEPLEN) - SEPLEN
525 : #if getStr_ENABLED
526 773053 : if (present(length)) then
527 0 : allocate(character(length,SKO) :: str) ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
528 0 : CHECK_ASSERTION(__LINE__, length >= lenStr, SK_"@getStr(): The input `length` argument must be sufficiently large such that the input `val` fits within the string buffer. length, lenStr."//getStr([length, lenStr]))
529 : else
530 773053 : allocate(character(lenStr,SKO) :: str) ! Fortran standard: Upon running the write statement, the untouched section of the record is padded with blanks.
531 : end if
532 : #endif
533 773053 : if (ValVec(1)) then
534 0 : endpos = 4_IK
535 427867 : str(1:endpos) = SKO_"TRUE"
536 : else
537 0 : endpos = 5_IK
538 345186 : str(1:endpos) = SKO_"FALSE"
539 : end if
540 2676299 : do i = 2_IK, sizeVal
541 1903246 : startpos = endpos + 1_IK
542 2676299 : if (ValVec(i)) then
543 942930 : endpos = endpos + SEPLEN + 4_IK
544 942930 : str(startpos:endpos) = SEP//"TRUE"
545 : else
546 960316 : endpos = endpos + SEPLEN + 5_IK
547 960316 : str(startpos:endpos) = SEP//"FALSE"
548 : end if
549 : end do
550 773053 : end subroutine
551 : #endif
552 : #undef CHECK_STR_LEN
553 : #undef SET_LENGTH
554 : #undef endpos
555 : #else
556 : !%%%%%%%%%%%%%%%%%%%%%%%%
557 : #error "Unrecognized interface."
558 : !%%%%%%%%%%%%%%%%%%%%%%%%
559 : #endif
|
