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

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody