代码如下，将输出所有 string 数组是否分别匹配 pattern 数组。
Logical Function match_wild(pattern, string)
! compare given string for match to pattern which may
! contain wildcard characters:
! "?" matching any one character, and
! "*" matching any zero or more characters.
! Both strings may have trailing spaces which are ignored.
! Authors: Clive Page, userid: cgp domain: le.ac.uk, 2003 (original code)
! Rolf Sander, 2005 (bug fixes and pattern preprocessing)
! Minor bug fixed by Clive Page, 2005 Nov 29, bad comment fixed 2005 Dec 2.
Implicit None
Character (Len=*), Intent (In) :: pattern ! pattern may contain * and ?
Character (Len=*), Intent (In) :: string ! string to be compared
Integer :: lenp, lenp2, lens, n, p2, p, s
Integer :: n_question, n_asterisk
Character (Len=len(pattern)) :: pattern2
lens = len_trim(string)
lenp = len_trim(pattern)
! If the pattern is empty, always return true
If (lenp==0) Then
match_wild = .True.
Return
End If
! The pattern must be preprocessed. All consecutive occurences of
! one or more question marks ('?') and asterisks ('*') are sorted and
! compressed. The result is stored in pattern2.
pattern2(:) = ''
p = 1 ! current position in pattern
p2 = 1 ! current position in pattern2
Do
If ((pattern(p:p)=='?') .Or. (pattern(p:p)=='*')) Then
! a special character was found in the pattern
n_question = 0
n_asterisk = 0
Do While (p<=lenp)
! count the consecutive question marks and asterisks
If ((pattern(p:p)/='?') .And. (pattern(p:p)/='*')) Exit
If (pattern(p:p)=='?') n_question = n_question + 1
If (pattern(p:p)=='*') n_asterisk = n_asterisk + 1
p = p + 1
End Do
If (n_question>0) Then ! first, all the question marks
pattern2(p2:p2+n_question-1) = repeat('?', n_question)
p2 = p2 + n_question
End If
If (n_asterisk>0) Then ! next, the asterisk (only one!)
pattern2(p2:p2) = '*'
p2 = p2 + 1
End If
Else
! just a normal character
pattern2(p2:p2) = pattern(p:p)
p2 = p2 + 1
p = p + 1
End If
If (p>lenp) Exit
End Do
!! lenp2 = p2 - 1
lenp2 = len_trim(pattern2)
! The modified wildcard in pattern2 is compared to the string:
p2 = 1
s = 1
match_wild = .False.
Do
If (pattern2(p2:p2)=='?') Then
! accept any char in string
p2 = p2 + 1
s = s + 1
Else If (pattern2(p2:p2)=='*') Then
p2 = p2 + 1
If (p2>lenp2) Then
! anything goes in rest of string
match_wild = .True.
Exit ! .TRUE.
Else
! search string for char at p2
n = index(string(s:), pattern2(p2:p2))
If (n==0) Exit ! .FALSE.
s = n + s - 1
End If
Else If (pattern2(p2:p2)==string(s:s)) Then
! single char match
p2 = p2 + 1
s = s + 1
Else
! non-match
Exit ! .FALSE.
End If
If (p2>lenp2 .And. s>lens) Then
! end of both pattern2 and string
match_wild = .True.
Exit ! .TRUE.
End If
!! IF (s > lens .AND. (pattern2(p2:p2) == "*") .AND. p2 == lenp2) THEN
!! above line buggy since p2 can be beyond end of string pattern2 by this point. CGP
If (s>lens .And. p2==lenp) Then
If (pattern2(p2:p2)=='*') Then
! "*" at end of pattern2 represents an empty string
match_wild = .True.
Exit
End If
End If
If (p2>lenp2 .Or. s>lens) Then
! end of either pattern2 or string
Exit ! .FALSE.
End If
End Do
End Function match_wild
Program www_fcode_cn
Implicit None
Integer, Parameter :: np = 20, ns = 5
Character :: pattern(np)*8, string(ns)*12
Integer :: s, p
Logical :: match_wild
External match_wild
string = (/ 'a.f90 ', 'a1.f90 ', 'a12.f90 ', 'a.f ', &
'fcode.cn ' /)
pattern = (/ 'a*.f90 ', 'a?*.f90 ', 'a*?.f90 ', 'a?*?.f90', 'a*.f90 ', &
'a***.f ', 'a*?*?*? ', 'a**b**c*', 'a*?*b???', '??? ', '* ', &
'? ', ' ', '**?** ', '?* ', '*?* ', '*.f90 ', &
'*? ', 'a*??.f90', '????? ' /)
Write (*, '(t17, 100a9)') string
Do p = 1, np
Write (*, '(a, 100L9)') pattern(p), (match_wild(pattern(p),string(s)), s=1 &
, ns)
End Do
End Program www_fcode_cn
