6 implicit none ;
private
8 public lowercase, uppercase
9 public left_int, left_ints
10 public left_real, left_reals
11 public string_functions_unit_tests
14 public extract_integer
23 function lowercase(input_string)
24 character(len=*),
intent(in) :: input_string
25 character(len=len(input_string)) :: lowercase
29 integer,
parameter :: co=iachar(
'a')-iachar(
'A')
32 lowercase = input_string
33 do k=1, len_trim(input_string)
34 if (lowercase(k:k) >=
'A' .and. lowercase(k:k) <=
'Z') &
35 lowercase(k:k) = achar(ichar(lowercase(k:k))+co)
37 end function lowercase
41 function uppercase(input_string)
42 character(len=*),
intent(in) :: input_string
43 character(len=len(input_string)) :: uppercase
47 integer,
parameter :: co=iachar(
'A')-iachar(
'a')
50 uppercase = input_string
51 do k=1, len_trim(input_string)
52 if (uppercase(k:k) >=
'a' .and. uppercase(k:k) <=
'z') &
53 uppercase(k:k) = achar(ichar(uppercase(k:k))+co)
55 end function uppercase
60 integer,
intent(in) :: i
61 character(len=19) :: left_int
63 character(len=19) :: tmp
64 write(tmp(1:19),
'(I19)') i
65 write(left_int(1:19),
'(A)') adjustl(tmp)
71 integer,
intent(in) :: i(:)
72 character(len=1320) :: left_ints
74 character(len=1320) :: tmp
76 write(left_ints(1:1320),
'(A)') trim(left_int(i(1)))
80 write(left_ints(1:1320),
'(A,", ",A)') trim(tmp),trim(left_int(i(j)))
83 end function left_ints
86 function left_real(val)
87 real,
intent(in) :: val
88 character(len=32) :: left_real
92 if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3))
then
93 write(left_real,
'(F30.11)') val
94 if (.not.isformattedfloatequalto(left_real,val))
then
95 write(left_real,
'(F30.12)') val
96 if (.not.isformattedfloatequalto(left_real,val))
then
97 write(left_real,
'(F30.13)') val
98 if (.not.isformattedfloatequalto(left_real,val))
then
99 write(left_real,
'(F30.14)') val
100 if (.not.isformattedfloatequalto(left_real,val))
then
101 write(left_real,
'(F30.15)') val
102 if (.not.isformattedfloatequalto(left_real,val))
then
103 write(left_real,
'(F30.16)') val
110 l = len_trim(left_real)
111 if ((l<2) .or. (left_real(l-1:l) ==
".0") .or. &
112 (left_real(l:l) /=
"0"))
exit
115 elseif (val == 0.)
then
118 if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100))
then
119 write(left_real(1:32),
'(ES24.14E3)') val
120 if (.not.isformattedfloatequalto(left_real,val)) &
121 write(left_real(1:32),
'(ES24.15E3)') val
123 write(left_real(1:32),
'(ES23.14)') val
124 if (.not.isformattedfloatequalto(left_real,val)) &
125 write(left_real(1:32),
'(ES23.15)') val
128 ind = index(left_real,
"0E")
130 if (left_real(ind-1:ind-1) ==
".")
exit
131 left_real = left_real(1:ind-1)//left_real(ind+1:)
134 left_real = adjustl(left_real)
135 end function left_real
139 function left_reals(r,sep)
140 real,
intent(in) :: r(:)
141 character(len=*),
optional,
intent(in) :: sep
143 character(len=1320) :: left_reals
145 integer :: j, n, b, ns
147 character(len=10) :: separator
149 n=1 ; dowrite=.true. ; left_reals=
'' ; b=1
150 if (
present(sep))
then
151 separator=sep ; ns=len(sep)
153 separator=
', ' ; ns=2
158 if (r(j)==r(j+1))
then
165 write(left_reals(b:),
'(A)') separator
169 write(left_reals(b:),
'(A,"*",A)') trim(left_int(n)),trim(left_real(r(j)))
171 write(left_reals(b:),
'(A)') trim(left_real(r(j)))
173 n=1 ; b=len_trim(left_reals)+1
176 end function left_reals
179 function isformattedfloatequalto(str, val)
180 character(len=*),
intent(in) :: str
181 real,
intent(in) :: val
182 logical :: isformattedfloatequalto
186 isformattedfloatequalto=.false.
187 read(str(1:),*,err=987) scannedval
188 if (scannedval == val) isformattedfloatequalto=.true.
190 end function isformattedfloatequalto
195 character(len=120) function extractword(string, n)
196 character(len=*),
intent(in) :: string
197 integer,
intent(in) :: n
199 extractword = extract_word(string,
' ,', n)
201 end function extractword
206 character(len=120) function extract_word(string, separators, n)
207 character(len=*),
intent(in) :: string
208 character(len=*),
intent(in) :: separators
209 integer,
intent(in) :: n
211 integer :: ns, i, b, e, nw
212 logical :: lastcharisseperator
214 lastcharisseperator = .true.
215 ns = len_trim(string)
216 i = 0; b=0; e=0; nw=0
219 if (lastcharisseperator)
then
220 if (verify(string(i:i),separators)==0)
then
223 lastcharisseperator = .false.
228 if (verify(string(i:i),separators)==0)
then
229 lastcharisseperator = .true.
233 extract_word = trim(string(b:e))
239 if (b<=ns .and. nw==n-1) extract_word = trim(string(b:ns))
240 end function extract_word
243 integer function extract_integer(string, separators, n, missing_value)
244 character(len=*),
intent(in) :: string
245 character(len=*),
intent(in) :: separators
246 integer,
intent(in) :: n
247 integer,
optional,
intent(in) :: missing_value
249 integer :: ns, i, b, e, nw
250 character(len=20) :: word
252 word = extract_word(string, separators, n)
254 if (len_trim(word)>0)
then
255 read(word(1:len_trim(word)),*) extract_integer
257 if (
present(missing_value))
then
258 extract_integer = missing_value
264 end function extract_integer
267 real function extract_real(string, separators, n, missing_value)
268 character(len=*),
intent(in) :: string
269 character(len=*),
intent(in) :: separators
270 integer,
intent(in) :: n
271 real,
optional,
intent(in) :: missing_value
273 integer :: ns, i, b, e, nw
274 character(len=20) :: word
276 word = extract_word(string, separators, n)
278 if (len_trim(word)>0)
then
279 read(word(1:len_trim(word)),*) extract_real
281 if (
present(missing_value))
then
282 extract_real = missing_value
288 end function extract_real
291 character(len=120) function remove_spaces(string)
292 character(len=*),
intent(in) :: string
295 logical :: lastcharisseperator
296 lastcharisseperator = .true.
297 ns = len_trim(string)
301 if (string(i:i) /=
' ')
then
303 remove_spaces(o:o) = string(i:i)
307 remove_spaces(i:i) =
' '
309 remove_spaces = trim(remove_spaces)
310 end function remove_spaces
313 logical function string_functions_unit_tests(verbose)
315 logical,
intent(in) :: verbose
317 integer :: i(5) = (/ -1, 1, 3, 3, 0 /)
318 real :: r(8) = (/ 0., 1., -2., 1.3, 3.e-11, 3.e-11, 3.e-11, -5.1e12 /)
322 write(*,*)
'==== MOM_string_functions: string_functions_unit_tests ==='
323 fail = fail .or. localtests(v,left_int(-1),
'-1')
324 fail = fail .or. localtests(v,left_ints(i(:)),
'-1, 1, 3, 3, 0')
325 fail = fail .or. localtests(v,left_real(0.),
'0.0')
326 fail = fail .or. localtests(v,left_reals(r(:)),
'0.0, 1.0, -2.0, 1.3, 3*3.0E-11, -5.1E+12')
327 fail = fail .or. localtests(v,left_reals(r(:),sep=
' '),
'0.0 1.0 -2.0 1.3 3*3.0E-11 -5.1E+12')
328 fail = fail .or. localtests(v,left_reals(r(:),sep=
','),
'0.0,1.0,-2.0,1.3,3*3.0E-11,-5.1E+12')
329 fail = fail .or. localtests(v,extractword(
"One Two,Three",1),
"One")
330 fail = fail .or. localtests(v,extractword(
"One Two,Three",2),
"Two")
331 fail = fail .or. localtests(v,extractword(
"One Two,Three",3),
"Three")
332 fail = fail .or. localtests(v,extractword(
"One Two, Three",3),
"Three")
333 fail = fail .or. localtests(v,extractword(
" One Two,Three",1),
"One")
334 fail = fail .or. localtests(v,extract_word(
"One,Two,Three",
",",3),
"Three")
335 fail = fail .or. localtests(v,extract_word(
"One,Two,Three",
",",4),
"")
336 fail = fail .or. localtests(v,remove_spaces(
"1 2 3"),
"123")
337 fail = fail .or. localtests(v,remove_spaces(
" 1 2 3"),
"123")
338 fail = fail .or. localtests(v,remove_spaces(
"1 2 3 "),
"123")
339 fail = fail .or. localtests(v,remove_spaces(
"123"),
"123")
340 fail = fail .or. localtests(v,remove_spaces(
" "),
"")
341 fail = fail .or. localtests(v,remove_spaces(
""),
"")
342 fail = fail .or. localtesti(v,extract_integer(
"1",
"",1),1)
343 fail = fail .or. localtesti(v,extract_integer(
"1,2,3",
",",1),1)
344 fail = fail .or. localtesti(v,extract_integer(
"1,2",
",",2),2)
345 fail = fail .or. localtesti(v,extract_integer(
"1,2",
",",3),0)
346 fail = fail .or. localtesti(v,extract_integer(
"1,2",
",",4,4),4)
347 fail = fail .or. localtestr(v,extract_real(
"1.",
"",1),1.)
348 fail = fail .or. localtestr(v,extract_real(
"1.,2.,3.",
",",1),1.)
349 fail = fail .or. localtestr(v,extract_real(
"1.,2.",
",",2),2.)
350 fail = fail .or. localtestr(v,extract_real(
"1.,2.",
",",3),0.)
351 fail = fail .or. localtestr(v,extract_real(
"1.,2.",
",",4,4.),4.)
352 if (.not. fail)
write(*,*)
'Pass'
353 string_functions_unit_tests = fail
354 end function string_functions_unit_tests
357 logical function localtests(verbose,str1,str2)
358 logical,
intent(in) :: verbose
359 character(len=*),
intent(in) :: str1
360 character(len=*),
intent(in) :: str2
362 if (trim(str1)/=trim(str2)) localtests=.true.
363 if (localtests .or. verbose)
then
364 write(*,*)
'>'//trim(str1)//
'<'
365 if (localtests)
write(*,*) trim(str1),
':',trim(str2),
'<-- FAIL'
367 end function localtests
370 logical function localtesti(verbose,i1,i2)
371 logical,
intent(in) :: verbose
372 integer,
intent(in) :: i1
373 integer,
intent(in) :: i2
375 if (i1/=i2) localtesti=.true.
376 if (localtesti .or. verbose)
then
378 if (localtesti)
write(*,*) i1,
'!=',i2,
'<-- FAIL'
380 end function localtesti
383 logical function localtestr(verbose,r1,r2)
384 logical,
intent(in) :: verbose
385 real,
intent(in) :: r1
386 real,
intent(in) :: r2
388 if (r1/=r2) localtestr=.true.
389 if (localtestr .or. verbose)
then
391 if (localtestr)
write(*,*) r1,
'!=',r2,
'<-- FAIL'
393 end function localtestr
397 function slasher(dir)
398 character(len=*),
intent(in) :: dir
400 character(len=len(dir)+2) :: slasher
402 if (len_trim(dir) == 0)
then
404 elseif (dir(len_trim(dir):len_trim(dir)) ==
'/')
then
407 slasher = trim(dir)//
"/"