1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
module fpm_strings
use iso_fortran_env, only: int64
implicit none
private
public :: f_string, lower, split, str_ends_with, string_t
public :: string_array_contains, string_cat, operator(.in.), fnv_1a
type string_t
character(len=:), allocatable :: s
end type
interface operator(.in.)
module procedure string_array_contains
end interface
interface fnv_1a
procedure :: fnv_1a_char
procedure :: fnv_1a_string_t
end interface fnv_1a
contains
logical function str_ends_with(s, e) result(r)
character(*), intent(in) :: s, e
integer :: n1, n2
n1 = len(s)-len(e)+1
n2 = len(s)
if (n1 < 1) then
r = .false.
else
r = (s(n1:n2) == e)
end if
end function str_ends_with
function f_string(c_string)
use iso_c_binding
character(len=1), intent(in) :: c_string(:)
character(:), allocatable :: f_string
integer :: i, n
i = 0
do while(c_string(i+1) /= C_NULL_CHAR)
i = i + 1
end do
n = i
allocate(character(n) :: f_string)
do i=1,n
f_string(i:i) = c_string(i)
end do
end function f_string
!> Hash a character(*) string of default kind
pure function fnv_1a_char(input, seed) result(hash)
character(*), intent(in) :: input
integer(int64), intent(in), optional :: seed
integer(int64) :: hash
integer :: i
integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64
integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64
if (present(seed)) then
hash = seed
else
hash = FNV_OFFSET_32
end if
do i=1,len(input)
hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32
end do
end function fnv_1a_char
!> Hash a string_t array of default kind
pure function fnv_1a_string_t(input, seed) result(hash)
type(string_t), intent(in) :: input(:)
integer(int64), intent(in), optional :: seed
integer(int64) :: hash
integer :: i
hash = fnv_1a(input(1)%s,seed)
do i=2,size(input)
hash = fnv_1a(input(i)%s,hash)
end do
end function fnv_1a_string_t
elemental pure function lower(str,begin,end) result (string)
! Changes a string to lowercase over specified range
! Author: John S. Urban
! License: Public Domain
character(*), intent(In) :: str
character(len(str)) :: string
integer,intent(in),optional :: begin, end
integer :: i
integer :: ibegin, iend
string = str
ibegin = 1
if (present(begin))then
ibegin = max(ibegin,begin)
endif
iend = len_trim(str)
if (present(end))then
iend= min(iend,end)
endif
do i = ibegin, iend ! step thru each letter in the string in specified range
select case (str(i:i))
case ('A':'Z')
string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule
case default
end select
end do
end function lower
logical function string_array_contains(search_string,array)
! Check if array of string_t contains a particular string
!
character(*), intent(in) :: search_string
type(string_t), intent(in) :: array(:)
integer :: i
string_array_contains = any([(array(i)%s==search_string, &
i=1,size(array))])
end function string_array_contains
!> Concatenate an array of type(string_t) into
!> a single character
function string_cat(strings,delim) result(cat)
type(string_t), intent(in) :: strings(:)
character(*), intent(in), optional :: delim
character(:), allocatable :: cat
integer :: i,n
character(:), allocatable :: delim_str
if (size(strings) < 1) return
if (present(delim)) then
delim_str = delim
else
delim_str = ''
end if
cat = strings(1)%s
do i=2,size(strings)
cat = cat//delim_str//strings(i)%s
end do
end function string_cat
subroutine split(input_line,array,delimiters,order,nulls)
! parse string on delimiter characters and store tokens into an allocatable array"
! Author: John S. Urban
! License: Public Domain
! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array.
! o by default adjacent delimiters in the input string do not create an empty string in the output array
! o no quoting of delimiters is supported
character(len=*),intent(in) :: input_line ! input string to tokenize
character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters
character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right]
character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend
character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens
integer :: n ! max number of strings INPUT_LINE could split into if all delimiter
integer,allocatable :: ibegin(:) ! positions in input string where tokens start
integer,allocatable :: iterm(:) ! positions in input string where tokens end
character(len=:),allocatable :: dlim ! string containing delimiter characters
character(len=:),allocatable :: ordr ! string containing order keyword
character(len=:),allocatable :: nlls ! string containing nulls keyword
integer :: ii,iiii ! loop parameters used to control print order
integer :: icount ! number of tokens found
integer :: ilen ! length of input string with trailing spaces trimmed
integer :: i10,i20,i30 ! loop counters
integer :: icol ! pointer into input string as it is being parsed
integer :: idlim ! number of delimiter characters
integer :: ifound ! where next delimiter character is found in remaining input string data
integer :: inotnull ! count strings not composed of delimiters
integer :: ireturn ! number of tokens returned
integer :: imax ! length of longest token
! decide on value for optional DELIMITERS parameter
if (present(delimiters)) then ! optional delimiter list was present
if(delimiters.ne.'')then ! if DELIMITERS was specified and not null use it
dlim=delimiters
else ! DELIMITERS was specified on call as empty string
dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified
endif
else ! no delimiter value was specified
dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified
endif
idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string
if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter
if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter
n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter
allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens
allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens
ibegin(:)=1
iterm(:)=1
ilen=len(input_line) ! ILEN is the column position of the last non-blank character
icount=0 ! how many tokens found
inotnull=0 ! how many tokens found not composed of delimiters
imax=0 ! length of longest token found
select case (ilen)
case (:0) ! command was totally blank
case default ! there is at least one non-delimiter in INPUT_LINE if get here
icol=1 ! initialize pointer into input line
INFINITE: do i30=1,ilen,1 ! store into each array element
ibegin(i30)=icol ! assume start new token on the character
if(index(dlim(1:idlim),input_line(icol:icol)).eq.0)then ! if current character is not a delimiter
iterm(i30)=ilen ! initially assume no more tokens
do i10=1,idlim ! search for next delimiter
ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10))
IF(ifound.gt.0)then
iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2)
endif
enddo
icol=iterm(i30)+2 ! next place to look as found end of this token
inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters
else ! character is a delimiter for a null string
iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning
icol=icol+1 ! advance pointer into input string
endif
imax=max(imax,iterm(i30)-ibegin(i30)+1)
icount=i30 ! increment count of number of tokens found
if(icol.gt.ilen)then ! no text left
exit INFINITE
endif
enddo INFINITE
end select
select case (trim(adjustl(nlls)))
case ('ignore','','ignoreend')
ireturn=inotnull
case default
ireturn=icount
end select
allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return
!allocate(array(ireturn)) ! allocate the array to turn
select case (trim(adjustl(ordr))) ! decide which order to store tokens
case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first
case default ; ii=1 ; iiii=1 ! first to last
end select
do i20=1,icount ! fill the array with the tokens that were found
if(iterm(i20).lt.ibegin(i20))then
select case (trim(adjustl(nlls)))
case ('ignore','','ignoreend')
case default
array(ii)=' '
ii=ii+iiii
end select
else
array(ii)=input_line(ibegin(i20):iterm(i20))
ii=ii+iiii
endif
enddo
end subroutine split
end module fpm_strings
|
