pure function stringify(value, separator)
use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64
class(*), intent(in) :: value(:)
character(*), optional, intent(in) :: separator
character(:), allocatable :: stringify
integer, parameter :: sizelimit = 1024
character(:), allocatable :: buffer, delimiter, format
character(:), allocatable :: value_c(:)
integer :: i, n, offset
if (present(separator)) then
delimiter = separator
else
delimiter = ', '
end if
n = min(size(value), sizelimit)
if (n == 0) then
stringify = ''
return
end if
select type (value)
type is (character(*))
allocate(character(len(value) * n + len(delimiter) * (n - 1)) :: buffer)
buffer(:) = ''
offset = 0
! Workaround for a bug in GNU Fortran >= 12. This is perhaps the manifestation of GCC Bugzilla Bug 100819.
! When a character string array is passed as the actual argument to an unlimited polymorphic dummy argument,
! its array index and length parameter are mishandled.
allocate(character(len(value)) :: value_c(size(value)))
value_c(:) = value(:)
do i = 1, n
if (len(delimiter) > 0 .and. i > 1) then
buffer(offset + 1:offset + len(delimiter)) = delimiter
offset = offset + len(delimiter)
end if
if (len_trim(adjustl(value_c(i))) > 0) then
buffer(offset + 1:offset + len_trim(adjustl(value_c(i)))) = trim(adjustl(value_c(i)))
offset = offset + len_trim(adjustl(value_c(i)))
end if
end do
deallocate(value_c)
type is (integer(int32))
allocate(character(11 * n + len(delimiter) * (n - 1)) :: buffer)
allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))'
write(buffer, format) value
type is (integer(int64))
allocate(character(20 * n + len(delimiter) * (n - 1)) :: buffer)
allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))'
write(buffer, format) value
type is (logical)
allocate(character(1 * n + len(delimiter) * (n - 1)) :: buffer)
allocate(character(13 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(', n, '(l1, :, "', delimiter, '"))'
write(buffer, format) value
type is (real(real32))
allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer)
if (maxval(abs(value)) < 1.0e5_real32) then
allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))'
else
allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))'
end if
write(buffer, format) value
type is (real(real64))
allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer)
if (maxval(abs(value)) < 1.0e5_real64) then
allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))'
else
allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format)
write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))'
end if
write(buffer, format) value
class default
stringify = ''
return
end select
stringify = trim(buffer)
end function stringify