MOM_string_functions.F90

1! This file is part of MOM6, the Modular Ocean Model version 6.
2! See the LICENSE file for licensing information.
3! SPDX-License-Identifier: Apache-2.0
4
5!> Handy functions for manipulating strings
7
8use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit
9
10implicit none ; private
11
12public lowercase, uppercase
13public left_int, left_ints
16public extractword
17public extract_word
18public extract_integer
19public extract_real
20public remove_spaces
21public slasher
23public ints_to_string
24
25contains
26
27!> Return a string in which all uppercase letters have been replaced by
28!! their lowercase counterparts.
29function lowercase(input_string)
30 character(len=*), intent(in) :: input_string !< The string to modify
31 character(len=len(input_string)) :: lowercase !< The modified output string
32! This function returns a string in which all uppercase letters have been
33! replaced by their lowercase counterparts. It is loosely based on the
34! lowercase function in mpp_util.F90.
35 integer, parameter :: co=iachar('a')-iachar('A') ! case offset
36 integer :: k
37
38 lowercase = input_string
39 do k=1, len_trim(input_string)
40 if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') &
41 lowercase(k:k) = achar(ichar(lowercase(k:k))+co)
42 enddo
43end function lowercase
44
45!> Return a string in which all uppercase letters have been replaced by
46!! their lowercase counterparts.
47function uppercase(input_string)
48 character(len=*), intent(in) :: input_string !< The string to modify
49 character(len=len(input_string)) :: uppercase !< The modified output string
50! This function returns a string in which all lowercase letters have been
51! replaced by their uppercase counterparts. It is loosely based on the
52! uppercase function in mpp_util.F90.
53 integer, parameter :: co=iachar('A')-iachar('a') ! case offset
54 integer :: k
55
56 uppercase = input_string
57 do k=1, len_trim(input_string)
58 if (uppercase(k:k) >= 'a' .and. uppercase(k:k) <= 'z') &
59 uppercase(k:k) = achar(ichar(uppercase(k:k))+co)
60 enddo
61end function uppercase
62
63!> Returns a character string of a left-formatted integer
64!! e.g. "123 " (assumes 19 digit maximum)
65function left_int(i)
66 integer, intent(in) :: i !< The integer to convert to a string
67 character(len=19) :: left_int !< The output string
68
69 character(len=19) :: tmp
70 write(tmp(1:19),'(I19)') i
71 write(left_int(1:19),'(A)') adjustl(tmp)
72end function left_int
73
74!> Returns a character string of a comma-separated, compact formatted,
75!! integers e.g. "1, 2, 3, 4"
76function left_ints(i)
77 integer, intent(in) :: i(:) !< The array of integers to convert to a string
78 character(len=1320) :: left_ints !< The output string
79
80 character(len=1320) :: tmp
81 integer :: j
82 write(left_ints(1:1320),'(A)') trim(left_int(i(1)))
83 if (size(i)>1) then
84 do j=2,size(i)
85 tmp=left_ints
86 write(left_ints(1:1320),'(A,", ",A)') trim(tmp),trim(left_int(i(j)))
87 enddo
88 endif
89end function left_ints
90
91!> Returns a left-justified string with a real formatted like '(G)'
92function left_real(val)
93 real, intent(in) :: val !< The real variable to convert to a string, in arbitrary units [A]
94 character(len=32) :: left_real !< The output string
95
96 integer :: l, ind
97
98 if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then
99 write(left_real, '(F30.11)') val
100 if (.not.isformattedfloatequalto(left_real,val)) then
101 write(left_real, '(F30.12)') val
102 if (.not.isformattedfloatequalto(left_real,val)) then
103 write(left_real, '(F30.13)') val
104 if (.not.isformattedfloatequalto(left_real,val)) then
105 write(left_real, '(F30.14)') val
106 if (.not.isformattedfloatequalto(left_real,val)) then
107 write(left_real, '(F30.15)') val
108 if (.not.isformattedfloatequalto(left_real,val)) then
109 write(left_real, '(F30.16)') val
110 endif
111 endif
112 endif
113 endif
114 endif
115 do
116 l = len_trim(left_real)
117 if ((l<2) .or. (left_real(l-1:l) == ".0") .or. &
118 (left_real(l:l) /= "0")) exit
119 left_real(l:l) = " "
120 enddo
121 elseif (val == 0.) then
122 left_real = "0.0"
123 else
124 if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then
125 write(left_real(1:32), '(ES24.14E3)') val
126 if (.not.isformattedfloatequalto(left_real,val)) &
127 write(left_real(1:32), '(ES24.15E3)') val
128 else
129 write(left_real(1:32), '(ES23.14)') val
130 if (.not.isformattedfloatequalto(left_real,val)) &
131 write(left_real(1:32), '(ES23.15)') val
132 endif
133 do
134 ind = index(left_real,"0E")
135 if (ind == 0) exit
136 if (left_real(ind-1:ind-1) == ".") exit
137 left_real = left_real(1:ind-1)//left_real(ind+1:)
138 enddo
139 endif
140 left_real = adjustl(left_real)
141end function left_real
142
143!> Returns a character string of a comma-separated, compact formatted, reals
144!! e.g. "1., 2., 5*3., 5.E2"
145function left_reals(r,sep)
146 real, intent(in) :: r(:) !< The array of real variables to convert to a string, in arbitrary units [A]
147 character(len=*), optional, intent(in) :: sep !< The separator between
148 !! successive values, by default it is ', '.
149 character(len=:), allocatable :: left_reals !< The output string
150
151 integer :: j, n, ns
152 logical :: dowrite
153 character(len=10) :: separator
154
155 n=1 ; dowrite=.true. ; left_reals=''
156 if (present(sep)) then
157 separator=sep ; ns=len(sep)
158 else
159 separator=', ' ; ns=2
160 endif
161 do j=1,size(r)
162 dowrite=.true.
163 if (j<size(r)) then
164 if (r(j)==r(j+1)) then
165 n=n+1
166 dowrite=.false.
167 endif
168 endif
169 if (dowrite) then
170 if (len(left_reals)>0) then ! Write separator if a number has already been written
171 left_reals = left_reals // separator(1:ns)
172 endif
173 if (n>1) then
174 left_reals = left_reals // trim(left_int(n)) // "*" // trim(left_real(r(j)))
175 else
176 left_reals = left_reals // trim(left_real(r(j)))
177 endif
178 n=1
179 endif
180 enddo
181end function left_reals
182
183!> Returns True if the string can be read/parsed to give the exact value of "val"
184function isformattedfloatequalto(str, val)
185 character(len=*), intent(in) :: str !< The string to parse
186 real, intent(in) :: val !< The real value to compare with, in arbitrary units [A]
187 logical :: isformattedfloatequalto
188 ! Local variables
189 real :: scannedval ! The value extraced from str, in arbitrary units [A]
190
192 read(str(1:),*,err=987) scannedval
193 if (scannedval == val) isformattedfloatequalto=.true.
194 987 return
195end function isformattedfloatequalto
196
197!> Returns the string corresponding to the nth word in the argument
198!! or "" if the string is not long enough. Both spaces and commas
199!! are interpreted as separators.
200character(len=120) function extractword(string, n)
201 character(len=*), intent(in) :: string !< The string to scan
202 integer, intent(in) :: n !< Number of word to extract
203
204 extractword = extract_word(string, ' ,', n)
205
206end function extractword
207
208!> Returns the string corresponding to the nth word in the argument
209!! or "" if the string is not long enough. Words are delineated
210!! by the mandatory separators argument.
211character(len=120) function extract_word(string, separators, n)
212 character(len=*), intent(in) :: string !< String to scan
213 character(len=*), intent(in) :: separators !< Characters to use for delineation
214 integer, intent(in) :: n !< Number of word to extract
215 ! Local variables
216 integer :: ns, i, b, e, nw
217 logical :: lastcharisseperator
218 extract_word = ''
219 lastcharisseperator = .true.
220 ns = len_trim(string)
221 i = 0 ; b=0 ; e=0 ; nw=0
222 do while (i<ns)
223 i = i+1
224 if (lastcharisseperator) then ! search for end of word
225 if (verify(string(i:i),separators)==0) then
226 continue ! Multiple separators
227 else
228 lastcharisseperator = .false. ! character is beginning of word
229 b = i
230 continue
231 endif
232 else ! continue search for end of word
233 if (verify(string(i:i),separators)==0) then
234 lastcharisseperator = .true.
235 e = i-1 ! Previous character is end of word
236 nw = nw+1
237 if (nw==n) then
238 extract_word = trim(string(b:e))
239 return
240 endif
241 endif
242 endif
243 enddo
244 if (b<=ns .and. nw==n-1) extract_word = trim(string(b:ns))
245end function extract_word
246
247!> Returns the integer corresponding to the nth word in the argument.
248integer function extract_integer(string, separators, n, missing_value)
249 character(len=*), intent(in) :: string !< String to scan
250 character(len=*), intent(in) :: separators !< Characters to use for delineation
251 integer, intent(in) :: n !< Number of word to extract
252 integer, optional, intent(in) :: missing_value !< Value to assign if word is missing
253 ! Local variables
254 character(len=20) :: word
255
256 word = extract_word(string, separators, n)
257
258 if (len_trim(word)>0) then
259 read(word(1:len_trim(word)),*) extract_integer
260 else
261 if (present(missing_value)) then
262 extract_integer = missing_value
263 else
265 endif
266 endif
267
268end function extract_integer
269
270!> Returns the real corresponding to the nth word in the argument, in arbitrary units [A].
271real function extract_real(string, separators, n, missing_value)
272 character(len=*), intent(in) :: string !< String to scan
273 character(len=*), intent(in) :: separators !< Characters to use for delineation
274 integer, intent(in) :: n !< Number of word to extract
275 real, optional, intent(in) :: missing_value !< Value to assign if word is missing, in arbitrary units [A]
276 ! Local variables
277 character(len=20) :: word
278
279 word = extract_word(string, separators, n)
280
281 if (len_trim(word)>0) then
282 read(word(1:len_trim(word)),*) extract_real
283 else
284 if (present(missing_value)) then
285 extract_real = missing_value
286 else
287 extract_real = 0
288 endif
289 endif
290
291end function extract_real
292
293!> Returns string with all spaces removed.
294character(len=120) function remove_spaces(string)
295 character(len=*), intent(in) :: string !< String to scan
296 ! Local variables
297 integer :: ns, i, o
298 logical :: lastcharisseperator
299 lastcharisseperator = .true.
300 ns = len_trim(string)
301 i = 0 ; o = 0
302 do while (i<ns)
303 i = i+1
304 if (string(i:i) /= ' ') then ! Copy character to output string
305 o = o + 1
306 remove_spaces(o:o) = string(i:i)
307 endif
308 enddo
309 do i = o+1, 120
310 remove_spaces(i:i) = ' ' ! Wipe any non-empty characters
311 enddo
313end function remove_spaces
314
315!> Returns true if a unit test of string_functions fails.
316logical function string_functions_unit_tests(verbose)
317 ! Arguments
318 logical, intent(in) :: verbose !< If true, write results to stdout
319 ! Local variables
320 integer :: i(5) = (/ -1, 1, 3, 3, 0 /)
321 ! This is an array of real test values, in arbitrary units [A]
322 real :: r(8) = (/ 0., 1., -2., 1.3, 3.e-11, 3.e-11, 3.e-11, -5.1e12 /)
323 logical :: fail, v
324 fail = .false.
325 v = verbose
326 write(stdout,*) '==== MOM_string_functions: string_functions_unit_tests ==='
327 fail = fail .or. localtests(v,left_int(-1),'-1')
328 fail = fail .or. localtests(v,left_ints(i(:)),'-1, 1, 3, 3, 0')
329 fail = fail .or. localtests(v,left_real(0.),'0.0')
330 fail = fail .or. localtests(v,left_reals(r(:)),'0.0, 1.0, -2.0, 1.3, 3*3.0E-11, -5.1E+12')
331 fail = fail .or. localtests(v,left_reals(r(:),sep=' '),'0.0 1.0 -2.0 1.3 3*3.0E-11 -5.1E+12')
332 fail = fail .or. localtests(v,left_reals(r(:),sep=','),'0.0,1.0,-2.0,1.3,3*3.0E-11,-5.1E+12')
333 fail = fail .or. localtests(v,ints_to_string(i(:),5),'_-0001_0001_0003_0003_0000')
334 fail = fail .or. localtests(v,ints_to_string(i(2:),2),'_0001_0003')
335 fail = fail .or. localtests(v,ints_to_string(i(:)),'_-0001_0001_0003')
336 fail = fail .or. localtests(v,trim_trailing_commas("One, Two, Three, "), "One, Two, Three")
337 fail = fail .or. localtests(v,extractword("One Two,Three",1),"One")
338 fail = fail .or. localtests(v,extractword("One Two,Three",2),"Two")
339 fail = fail .or. localtests(v,extractword("One Two,Three",3),"Three")
340 fail = fail .or. localtests(v,extractword("One Two, Three",3),"Three")
341 fail = fail .or. localtests(v,extractword(" One Two,Three",1),"One")
342 fail = fail .or. localtests(v,extract_word("One,Two,Three",",",3),"Three")
343 fail = fail .or. localtests(v,extract_word("One,Two,Three",",",4),"")
344 fail = fail .or. localtests(v,remove_spaces("1 2 3"),"123")
345 fail = fail .or. localtests(v,remove_spaces(" 1 2 3"),"123")
346 fail = fail .or. localtests(v,remove_spaces("1 2 3 "),"123")
347 fail = fail .or. localtests(v,remove_spaces("123"),"123")
348 fail = fail .or. localtests(v,remove_spaces(" "),"")
349 fail = fail .or. localtests(v,remove_spaces(""),"")
350 fail = fail .or. localtesti(v,extract_integer("1","",1),1)
351 fail = fail .or. localtesti(v,extract_integer("1,2,3",",",1),1)
352 fail = fail .or. localtesti(v,extract_integer("1,2",",",2),2)
353 fail = fail .or. localtesti(v,extract_integer("1,2",",",3),0)
354 fail = fail .or. localtesti(v,extract_integer("1,2",",",4,4),4)
355 fail = fail .or. localtestr(v,extract_real("1.","",1),1.)
356 fail = fail .or. localtestr(v,extract_real("1.,2.,3.",",",1),1.)
357 fail = fail .or. localtestr(v,extract_real("1.,2.",",",2),2.)
358 fail = fail .or. localtestr(v,extract_real("1.,2.",",",3),0.)
359 fail = fail .or. localtestr(v,extract_real("1.,2.",",",4,4.),4.)
360 if (.not. fail) write(stdout,*) 'Pass'
363
364!> True if str1 does not match str2. False otherwise.
365logical function localtests(verbose,str1,str2)
366 logical, intent(in) :: verbose !< If true, write results to stdout
367 character(len=*), intent(in) :: str1 !< String
368 character(len=*), intent(in) :: str2 !< String
369 localtests=.false.
370 if (trim(str1)/=trim(str2)) localtests=.true.
371 if (localtests .or. verbose) then
372 write(stdout,*) '>'//trim(str1)//'<'
373 if (localtests) then
374 write(stdout,*) trim(str1),':',trim(str2), '<-- FAIL'
375 write(stderr,*) trim(str1),':',trim(str2), '<-- FAIL'
376 endif
377 endif
378end function localtests
379
380!> True if i1 is not equal to i2. False otherwise.
381logical function localtesti(verbose,i1,i2)
382 logical, intent(in) :: verbose !< If true, write results to stdout
383 integer, intent(in) :: i1 !< Integer
384 integer, intent(in) :: i2 !< Integer
385 localtesti=.false.
386 if (i1/=i2) localtesti=.true.
387 if (localtesti .or. verbose) then
388 write(stdout,*) i1,i2
389 if (localtesti) then
390 write(stdout,*) i1,'!=',i2, '<-- FAIL'
391 write(stderr,*) i1,'!=',i2, '<-- FAIL'
392 endif
393 endif
394end function localtesti
395
396!> True if r1 is not equal to r2. False otherwise.
397logical function localtestr(verbose,r1,r2)
398 logical, intent(in) :: verbose !< If true, write results to stdout
399 real, intent(in) :: r1 !< The first value to compare, in arbitrary units [A]
400 real, intent(in) :: r2 !< The first value to compare, in arbitrary units [A]
401 localtestr=.false.
402 if (r1/=r2) localtestr=.true.
403 if (localtestr .or. verbose) then
404 write(stdout,*) r1,r2
405 if (localtestr) then
406 write(stdout,*) r1,'!=',r2, '<-- FAIL'
407 write(stderr,*) r1,'!=',r2, '<-- FAIL'
408 endif
409 endif
410end function localtestr
411
412!> Returns a directory name that is terminated with a "/" or "./" if the
413!! argument is an empty string.
414function slasher(dir)
415 character(len=*), intent(in) :: dir !< A directory to be terminated with a "/"
416 !! or changed to "./" if it is blank.
417 character(len=len(dir)+2) :: slasher
418
419 if (len_trim(dir) == 0) then
420 slasher = "./"
421 elseif (dir(len_trim(dir):len_trim(dir)) == '/') then
422 slasher = trim(dir)
423 else
424 slasher = trim(dir)//"/"
425 endif
426end function slasher
427
428!> Returns a left-adjusted string with trailing blanks and commas removed.
429function trim_trailing_commas(in_str) result(out_str)
430 character(len=*), intent(in) :: in_str !< A string that is to be left adjusted and have
431 !! its trailing commas and white space removed.
432 character(len=len(in_str)) :: out_str !< A left-adjusted version of in_str with
433 !! trailing commas and white space removed
434
435 out_str = trim(adjustl(in_str))
436 if (len_trim(out_str) > 0) then
437 if (out_str(len_trim(out_str):len_trim(out_str)) == ",") then
438 out_str = out_str(1:len_trim(out_str) - 1)
439 endif
440 out_str = trim(out_str)
441 endif
442
443end function trim_trailing_commas
444
445!> Convert the first n elements (3 by default) of an integer array into an underscore delimited string.
446function ints_to_string(a, n) result(i2s)
447 integer, dimension(:), intent(in) :: a !< The array of integers to translate
448 integer, optional , intent(in) :: n !< The number of elements to translate, by default the lesser
449 !! of 3 or all of the integers
450 character(len=5*size(a)+1) :: i2s !< The returned underscore delimited string of integers
451
452 character(len=8) :: i2s_temp
453 integer :: i, n_max
454
455 n_max = 3
456 if (present(n)) n_max = n
457
458 i2s = ''
459 do i=1,min(size(a), n_max)
460 if (a(i) < 0) then
461 write (i2s_temp, '(I5.4)') a(i)
462 else
463 write (i2s_temp, '(I4.4)') a(i)
464 endif
465 i2s = trim(i2s) //'_'// trim(i2s_temp)
466 enddo
467 i2s = adjustl(i2s)
468end function ints_to_string
469
470
471!> \namespace mom_string_functions
472!!
473!! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013.
474!!
475!! The functions here perform a set of useful manipulations of
476!! character strings. Although they are a part of MOM6, the do not
477!! require any other MOM software to be useful.
478
479end module mom_string_functions