string.F90 coverage: 94.12 %func 81.66 %block
1) module String_module
2)
3) ! IMPORTANT NOTE: This module can have no dependencies on other modules!!!
4)
5) use PFLOTRAN_Constants_module
6)
7) implicit none
8)
9) private
10)
11) #include "petsc/finclude/petscsys.h"
12)
13) PetscInt, parameter, public :: STRING_IS_INTEGER = 1
14) PetscInt, parameter, public :: STRING_IS_DOUBLE = 2
15) PetscInt, parameter, public :: STRING_IS_WORD = 3
16)
17) public :: StringCompare, &
18) StringCompareIgnoreCase, &
19) StringToUpper, &
20) StringToLower, &
21) StringReadQuotedWord, &
22) StringStartsWithAlpha, &
23) StringStartsWith, &
24) StringAdjustl, &
25) StringNull, &
26) StringFindEntryInList, &
27) StringSplit, &
28) StringSwapChar, &
29) StringFormatInt, &
30) StringFormatDouble, &
31) StringIntegerDoubleOrWord
32)
33) interface StringCompare
34) module procedure StringCompare1
35) module procedure StringCompare2
36) end interface
37)
38) interface StringCompareIgnoreCase
39) module procedure StringCompareIgnoreCase1
40) module procedure StringCompareIgnoreCase2
41) end interface
42)
43) contains
44)
45) ! ************************************************************************** !
46)
47) PetscBool function StringCompare1(string1,string2,n)
48) !
49) ! compares two strings
50) !
51) ! Author: Glenn Hammond
52) ! Date: 11/10/08
53) !
54)
55) implicit none
56)
57) PetscInt :: i, n
58) character(len=n) :: string1, string2
59)
60) do i=1,n
61) if (string1(i:i) /= string2(i:i)) then
62) StringCompare1 = PETSC_FALSE
63) return
64) endif
65) enddo
66)
67) StringCompare1 = PETSC_TRUE
68) return
69)
70) end function StringCompare1
71)
72) ! ************************************************************************** !
73)
74) PetscBool function StringCompare2(string1,string2)
75) !
76) ! compares two strings
77) !
78) ! Author: Glenn Hammond
79) ! Date: 10/25/11
80) !
81)
82) implicit none
83)
84) PetscInt :: i, length1, length2
85) character(len=*) :: string1, string2
86)
87) length1 = len_trim(string1)
88) length2 = len_trim(string2)
89) if (length1 /= length2) then
90) StringCompare2 = PETSC_FALSE
91) return
92) endif
93)
94) do i=1,length1
95) if (string1(i:i) /= string2(i:i)) then
96) StringCompare2 = PETSC_FALSE
97) return
98) endif
99) enddo
100)
101) StringCompare2 = PETSC_TRUE
102) return
103)
104) end function StringCompare2
105)
106) ! ************************************************************************** !
107)
108) function StringCompareIgnoreCase1(string1,string2,n)
109) !
110) ! compares two strings
111) !
112) ! Author: Glenn Hammond
113) ! Date: 11/10/08
114) !
115)
116) implicit none
117)
118) PetscInt :: i, n
119) character(len=n) :: string1, string2
120)
121) character(len=n) :: upper1, upper2
122) PetscBool :: StringCompareIgnoreCase1
123)
124) upper1 = string1
125) upper2 = string2
126)
127) call StringToUpper(upper1)
128) call StringToUpper(upper2)
129)
130) do i=1,n
131) if (upper1(i:i) /= upper2(i:i)) then
132) StringCompareIgnoreCase1 = PETSC_FALSE
133) return
134) endif
135) enddo
136)
137) StringCompareIgnoreCase1 = PETSC_TRUE
138) return
139)
140) end function StringCompareIgnoreCase1
141)
142) ! ************************************************************************** !
143)
144) function StringCompareIgnoreCase2(string1,string2)
145) !
146) ! StringCompare: compares two strings
147) !
148) ! Author: Glenn Hammond
149) ! Date: 11/10/08
150) !
151)
152) implicit none
153)
154) PetscInt :: i, length1, length2
155) character(len=*) :: string1, string2
156)
157) character(len=MAXSTRINGLENGTH) :: upper1, upper2
158) PetscBool :: StringCompareIgnoreCase2
159)
160) length1 = len_trim(string1)
161) length2 = len_trim(string2)
162) if (length1 /= length2) then
163) StringCompareIgnoreCase2 = PETSC_FALSE
164) return
165) endif
166)
167) upper1 = string1
168) upper2 = string2
169)
170) call StringToUpper(upper1)
171) call StringToUpper(upper2)
172)
173) do i=1,length1
174) if (upper1(i:i) /= upper2(i:i)) then
175) StringCompareIgnoreCase2 = PETSC_FALSE
176) return
177) endif
178) enddo
179)
180) StringCompareIgnoreCase2 = PETSC_TRUE
181) return
182)
183) end function StringCompareIgnoreCase2
184)
185) ! ************************************************************************** !
186)
187) subroutine StringToUpper(string)
188) !
189) ! converts lowercase characters in a card to uppercase
190) !
191) ! Author: Glenn Hammond
192) ! Date: 11/10/08
193) !
194)
195) implicit none
196)
197) PetscInt :: i
198) character(len=*) :: string
199)
200) do i=1,len_trim(string)
201) if (string(i:i) >= 'a' .and. string(i:i) <= 'z') then
202) string(i:i) = achar(iachar(string(i:i)) - 32)
203) endif
204) enddo
205)
206) end subroutine StringToUpper
207)
208) ! ************************************************************************** !
209)
210) subroutine StringToLower(string)
211) !
212) ! converts uppercase characters in a card to lowercase
213) !
214) ! Author: Glenn Hammond
215) ! Date: 11/10/08
216) !
217)
218) implicit none
219)
220) PetscInt :: i
221) character(len=*) :: string
222)
223) do i=1,len_trim(string)
224) if (string(i:i) >= 'A' .and. string(i:i) <= 'Z') then
225) string(i:i) = achar(iachar(string(i:i)) + 32)
226) endif
227) enddo
228)
229) end subroutine StringToLower
230)
231) ! ************************************************************************** !
232)
233) subroutine StringReadQuotedWord(string, name, return_blank_error, ierr)
234) !
235) ! reads and removes a name from a string read from the
236) ! database. "'" are used as delimiters.
237) !
238) ! Author: Glenn Hammond
239) ! Date: 11/10/08
240) !
241)
242) implicit none
243)
244) PetscInt :: i, begins, ends, realends, length
245) PetscBool :: return_blank_error ! Return an error for a blank line
246) ! Therefore, a blank line is not acceptable.
247) character(len=*) :: string
248) character(len=*) :: name
249) character(len=1), parameter :: tab = achar(9)
250) PetscBool :: openquotefound
251) PetscErrorCode :: ierr
252)
253) if (ierr /= 0) return
254)
255) openquotefound = PETSC_FALSE
256) ! Initialize character string to blank.
257) length = len_trim(name)
258) name(1:length) = repeat(' ',length)
259)
260) ierr = 0
261) length = len_trim(string)
262)
263) ! Remove leading blanks and tabs
264) i=1
265) do while(string(i:i) == ' ' .or. string(i:i) == tab)
266) i=i+1
267) enddo
268)
269) if (string(i:i) == "'") then
270) openquotefound = PETSC_TRUE
271) i=i+1
272) endif
273)
274) begins=i
275)
276) if (openquotefound) then
277) do while (string(i:i) /= "'")
278) if (i > length) exit
279) i=i+1
280) enddo
281) else
282) ! Count # of continuous characters (no blanks, commas, etc. in between)
283) do while (string(i:i) /= ' ' .and. string(i:i) /= ',' .and. &
284) string(i:i) /= tab)
285) i=i+1
286) enddo
287) endif
288)
289) realends = i
290) ends=i-1
291)
292) ! Avoid copying beyond the end of the word (32 characters).
293) if (ends-begins > MAXWORDLENGTH - 1) ends = begins + MAXWORDLENGTH - 1
294)
295) ! Copy (ends-begins) characters to 'chars'
296) name = string(begins:ends)
297) ! Remove chars from string
298) string = string(realends+1:)
299)
300) end subroutine StringReadQuotedWord
301)
302) ! ************************************************************************** !
303)
304) function StringStartsWithAlpha(string)
305) !
306) ! Determines whether a string starts with an alpha char
307) !
308) ! Author: Glenn Hammond
309) ! Date: 10/07/10
310) !
311)
312) implicit none
313)
314) character(len=*) :: string
315)
316) PetscBool :: StringStartsWithAlpha
317)
318) string = adjustl(string)
319)
320) if ((string(1:1) >= 'a' .and. string(1:1) <= 'z') .or. &
321) (string(1:1) >= 'A' .and. string(1:1) <= 'Z')) then
322) StringStartsWithAlpha = PETSC_TRUE
323) else
324) StringStartsWithAlpha = PETSC_FALSE
325) endif
326)
327) end function StringStartsWithAlpha
328)
329) ! ************************************************************************** !
330)
331) function StringStartsWith(string,string2)
332) !
333) ! Determines whether a string starts with characters
334) ! identical to another string
335) !
336) ! Author: Glenn Hammond
337) ! Date: 03/16/12
338) !
339)
340) implicit none
341)
342) character(len=*) :: string
343) character(len=*) :: string2
344)
345) PetscBool :: StringStartsWith
346)
347)
348) PetscInt :: length, i
349)
350) length = min(len_trim(string),len_trim(string2))
351)
352) do i = 1, length
353) if (string(i:i) /= string2(i:i)) then
354) StringStartsWith = PETSC_FALSE
355) return
356) endif
357) enddo
358)
359) StringStartsWith = PETSC_TRUE
360)
361) end function StringStartsWith
362)
363) ! ************************************************************************** !
364)
365) subroutine StringAdjustl(string)
366) !
367) ! Left adjusts a string by removing leading spaces and tabs.
368) ! This subroutine is needed because the adjustl() Fortran 90
369) ! intrinsic will not remove leading tabs.
370) !
371) ! Author: Richard Tran Mills
372) ! Date: 9/21/2010
373) !
374)
375) implicit none
376)
377) character(len=*) :: string
378)
379) PetscInt :: i
380) PetscInt :: string_length
381) character(len=1), parameter :: tab = achar(9)
382)
383) ! We have to manually convert any leading tabs into spaces, as the
384) ! adjustl() intrinsic does not eliminate leading tabs.
385) i=1
386) string_length = len_trim(string)
387) do while((string(i:i) == ' ' .or. string(i:i) == tab) .and. &
388) i <= string_length)
389) if (string(i:i) == tab) string(i:i) = ' '
390) i=i+1
391) enddo
392)
393) ! adjustl() will do what we want, now that tabs are removed.
394) string = adjustl(string)
395)
396) end subroutine StringAdjustl
397)
398) ! ************************************************************************** !
399)
400) function StringNull(string)
401) !
402) ! Returns PETSC_TRUE if a string is blank
403) !
404) ! Author: Glenn Hammond
405) ! Date: 10/07/10
406) !
407)
408) implicit none
409)
410) character(len=*) :: string
411)
412) PetscBool :: StringNull
413) PetscInt :: length
414)
415) length = len_trim(adjustl(string))
416) if (length > 0) then
417) StringNull = PETSC_FALSE
418) else
419) StringNull = PETSC_TRUE
420) endif
421)
422) end function StringNull
423)
424) ! ************************************************************************** !
425)
426) function StringFindEntryInList(string,string_array)
427) !
428) ! Returns the index of a string if found in a list
429) ! of strings
430) !
431) ! Author: Glenn Hammond
432) ! Date: 10/30/12
433) !
434)
435) implicit none
436)
437) character(len=*) :: string
438) character(len=*) :: string_array(:)
439)
440) PetscInt :: StringFindEntryInList
441) PetscInt :: i
442)
443) StringFindEntryInList = 0
444)
445) do i = 1, size(string_array)
446) if (StringCompare(string,string_array(i))) then
447) StringFindEntryInList = i
448) exit
449) endif
450) enddo
451)
452) end function StringFindEntryInList
453)
454) ! ************************************************************************** !
455)
456) subroutine StringSwapChar(string,char_in,char_out)
457) !
458) ! Swaps a character from a string
459) !
460) ! Author: Glenn Hammond
461) ! Date: 02/04/13
462) !
463)
464) implicit none
465)
466) character(len=*) :: string
467) character(len=1) :: char_in
468) character(len=1) :: char_out
469)
470) PetscInt :: i
471)
472) do i=1, len_trim(string)
473) if (string(i:i) == char_in(1:1)) string(i:i) = char_out(1:1)
474) enddo
475)
476) end subroutine StringSwapChar
477)
478) ! ************************************************************************** !
479)
480) function StringSplit(string,chars)
481) !
482) ! Splits a string based on a set of chars
483) !
484) ! Author: Glenn Hammond
485) ! Date: 01/28/13
486) !
487)
488) implicit none
489)
490) character(len=*) :: string
491) character(len=*) :: chars
492)
493) character(len=MAXSTRINGLENGTH), pointer :: strings(:), StringSplit(:)
494)
495) character(len=MAXSTRINGLENGTH) :: string1, string2
496) PetscInt :: i, icount, istart, iend, length, length_chars
497) PetscInt :: last_index
498)
499) nullify(StringSplit)
500)
501) ! determine how many delimiting block in string
502) length = len_trim(string)
503) length_chars = len_trim(chars)
504) icount = 0
505) last_index = 1
506) iend = length-length_chars+1
507) do i = 1, iend
508) string1 = string(i:i+length_chars-1)
509) if (StringCompare(string1,chars,length_chars)) then
510) last_index = i+1
511) icount = icount + 1
512) endif
513) enddo
514)
515) ! check for characters after last delimiter; add a string if they exist
516) if (last_index <= length) then
517) if (.not.StringNull(string(last_index:))) then
518) icount = icount + 1
519) endif
520) endif
521)
522) if (icount == 0) return
523)
524) ! allocate strings
525) allocate(strings(icount))
526) strings = ''
527)
528) ! split string into strings
529) istart = 1
530) icount = 0
531) iend = length-length_chars+1
532) i = 1
533) do
534) if (i > iend) exit
535) string1 = string(i:i+length_chars-1)
536) if (StringCompare(string1,chars,length_chars)) then
537) icount = icount + 1
538) strings(icount) = adjustl(string(istart:i-1))
539) i = i + length_chars
540) istart = i
541) else
542) i = i + 1
543) endif
544) enddo
545)
546) ! add remaining string
547) if (icount < size(strings)) then
548) icount = icount + 1
549) strings(icount) = adjustl(string(istart:))
550) endif
551)
552) StringSplit => strings
553)
554) end function StringSplit
555)
556) ! ************************************************************************** !
557)
558) function StringFormatInt(int_value)
559) !
560) ! Writes a integer to a string
561) !
562) ! Author: Glenn Hammond
563) ! Date: 01/13/12
564) !
565)
566) implicit none
567)
568) PetscInt :: int_value
569)
570) character(len=MAXWORDLENGTH) :: StringFormatInt
571)
572) write(StringFormatInt,'(1i12)') int_value
573)
574) StringFormatInt = adjustl(StringFormatInt)
575)
576) end function StringFormatInt
577)
578) ! ************************************************************************** !
579)
580) function StringFormatDouble(real_value)
581) !
582) ! Writes a double or real to a string
583) !
584) ! Author: Glenn Hammond
585) ! Date: 01/13/12
586) !
587)
588) implicit none
589)
590) PetscReal :: real_value
591)
592) character(len=MAXWORDLENGTH) :: StringFormatDouble
593)
594) write(StringFormatDouble,'(1es13.5)') real_value
595)
596) StringFormatDouble = adjustl(StringFormatDouble)
597)
598) end function StringFormatDouble
599)
600) ! ************************************************************************** !
601)
602) function StringIntegerDoubleOrWord(string)
603) !
604) ! Writes a double or real to a string
605) !
606) ! Author: Glenn Hammond
607) ! Date: 01/13/12
608) !
609)
610) implicit none
611)
612) character(len=*) :: string
613)
614) PetscInt :: StringIntegerDoubleOrWord
615)
616) PetscReal :: d
617) PetscInt :: i
618) PetscBool :: double_syntax_found
619) character(len=MAXWORDLENGTH) :: word
620) PetscErrorCode :: ierr
621)
622) StringIntegerDoubleOrWord = -999
623) ierr = 0
624) double_syntax_found = (index(string,'.') > 0 .or. &
625) index(string,'d') > 0 .or. index(string,'D') > 0 .or. &
626) index(string,'e') > 0 .or. index(string,'E') > 0)
627) read(string,*,iostat=ierr) i
628) if (ierr == 0) then
629) ! the Intel compiler does not alway catch the misread of a double to an
630) ! integer
631) if (double_syntax_found) then
632) StringIntegerDoubleOrWord = STRING_IS_DOUBLE
633) return
634) endif
635) StringIntegerDoubleOrWord = STRING_IS_INTEGER
636) return
637) endif
638) ierr = 0
639) read(string,*,iostat=ierr) d
640) if (ierr == 0) then
641) StringIntegerDoubleOrWord = STRING_IS_DOUBLE
642) return
643) endif
644) if (len_trim(string) > 0) StringIntegerDoubleOrWord = STRING_IS_WORD
645)
646) end function StringIntegerDoubleOrWord
647)
648) end module String_module