libsim Versione 7.2.1

◆ string_match()

recursive logical function string_match ( character(len=*), intent(in)  string,
character(len=*), intent(in)  pattern 
)
private

Tries to match the given string with the pattern.

Returns .TRUE. if the entire string matches the pattern, .FALSE. otherwise. Note: trailing blanks are ignored.

Parametri
[in]stringString to be examined
[in]patternGlob pattern to be used for the matching

Definizione alla linea 1302 del file char_utilities.F90.

1303! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1304! authors:
1305! Davide Cesari <dcesari@arpa.emr.it>
1306! Paolo Patruno <ppatruno@arpa.emr.it>
1307
1308! This program is free software; you can redistribute it and/or
1309! modify it under the terms of the GNU General Public License as
1310! published by the Free Software Foundation; either version 2 of
1311! the License, or (at your option) any later version.
1312
1313! This program is distributed in the hope that it will be useful,
1314! but WITHOUT ANY WARRANTY; without even the implied warranty of
1315! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1316! GNU General Public License for more details.
1317
1318! You should have received a copy of the GNU General Public License
1319! along with this program. If not, see <http://www.gnu.org/licenses/>.
1326#include "config.h"
1327MODULE char_utilities
1328USE kinds
1330USE io_units
1331IMPLICIT NONE
1332
1333CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
1334CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1335
1367INTERFACE to_char
1368 MODULE PROCEDURE int_to_char, byte_to_char, &
1369 real_to_char, double_to_char, logical_to_char, &
1370 char_to_char, char_to_char_miss
1371END INTERFACE
1372
1373
1392INTERFACE t2c
1393 MODULE PROCEDURE trim_int_to_char, trim_int_to_char_miss, &
1394 trim_byte_to_char, trim_byte_to_char_miss, &
1395 trim_real_to_char, trim_real_to_char_miss, &
1396 trim_double_to_char, trim_double_to_char_miss, trim_logical_to_char, &
1397 trim_char_to_char, trim_char_to_char_miss
1398END INTERFACE
1399
1400
1405TYPE line_split
1406 PRIVATE
1407 INTEGER :: align_type, ncols, nlines
1408 INTEGER, POINTER :: word_start(:), word_end(:)
1409 CHARACTER(len=1), POINTER :: paragraph(:,:)
1410END TYPE line_split
1411
1417INTERFACE delete
1418 MODULE PROCEDURE line_split_delete
1419END INTERFACE
1420
1421
1482INTERFACE match
1483 MODULE PROCEDURE string_match, string_match_v
1484END INTERFACE
1485
1486
1494TYPE progress_line
1495 DOUBLE PRECISION :: min=0.0d0
1496 DOUBLE PRECISION :: max=100.0d0
1497 DOUBLE PRECISION,PRIVATE :: curr=0.0d0
1498 CHARACTER(len=512),PRIVATE :: form='(''|'',I3.0,''%|'',A,''|'',10X,''|'')'
1499 CHARACTER(len=1),PRIVATE :: done='='
1500 CHARACTER(len=1),PRIVATE :: todo='-'
1501 INTEGER,PRIVATE :: barloc=8
1502 INTEGER,PRIVATE :: spin=0
1503 CONTAINS
1504 PROCEDURE :: update => progress_line_update_d, progress_line_update_i
1505 PROCEDURE :: alldone => progress_line_alldone
1506END TYPE progress_line
1507
1508CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
1509
1510PRIVATE
1511PUBLIC line_split
1512PUBLIC to_char, t2c, c2i, c2r, c2d, delete, match, &
1513 fchar_to_cstr, fchar_to_cstr_alloc, cstr_to_fchar, uppercase, lowercase, &
1514 align_center, l_nblnk, f_nblnk, word_split, &
1515 line_split_new, line_split_get_nlines, line_split_get_line, &
1516 suffixname, default_columns, wash_char, &
1517 print_status_line, done_status_line, progress_line
1518
1519CONTAINS
1520
1521! Version with integer argument, please use the generic \a to_char
1522! rather than this function directly.
1523ELEMENTAL FUNCTION int_to_char(in, miss, form) RESULT(char)
1524INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1525CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1526CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1527CHARACTER(len=11) :: char
1528
1529IF (PRESENT(miss)) THEN
1530 IF (.NOT.c_e(in)) THEN
1531 char = miss
1532 ELSE
1533 IF (PRESENT(form)) THEN
1534 WRITE(char,form)in
1535 ELSE
1536 WRITE(char,'(I0)')in
1537 ENDIF
1538 ENDIF
1539ELSE
1540 IF (PRESENT(form)) THEN
1541 WRITE(char,form)in
1542 ELSE
1543 WRITE(char,'(I0)')in
1544 ENDIF
1545ENDIF
1546
1547END FUNCTION int_to_char
1548
1549
1550FUNCTION trim_int_to_char(in) RESULT(char)
1551INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1552CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1553
1554char = to_char(in)
1555
1556END FUNCTION trim_int_to_char
1557
1558
1559FUNCTION trim_int_to_char_miss(in, miss) RESULT(char)
1560INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1561CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1562CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1563
1564char = to_char(in, miss=miss)
1565
1566END FUNCTION trim_int_to_char_miss
1567
1568
1569! Version with 1-byte integer argument, please use the generic \a to_char
1570! rather than this function directly.
1571ELEMENTAL FUNCTION byte_to_char(in, miss, form) RESULT(char)
1572INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1573CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1574CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1575CHARACTER(len=11) :: char
1576
1577IF (PRESENT(miss)) THEN
1578 IF (.NOT.c_e(in)) THEN
1579 char = miss
1580 ELSE
1581 IF (PRESENT(form)) THEN
1582 WRITE(char,form)in
1583 ELSE
1584 WRITE(char,'(I0)')in
1585 ENDIF
1586 ENDIF
1587ELSE
1588 IF (PRESENT(form)) THEN
1589 WRITE(char,form)in
1590 ELSE
1591 WRITE(char,'(I0)')in
1592 ENDIF
1593ENDIF
1594
1595END FUNCTION byte_to_char
1596
1597
1598FUNCTION trim_byte_to_char(in) RESULT(char)
1599INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1600CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1601
1602char = to_char(in)
1603
1604END FUNCTION trim_byte_to_char
1605
1606
1607FUNCTION trim_byte_to_char_miss(in,miss) RESULT(char)
1608INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1609CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1610CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1611
1612char = to_char(in, miss=miss)
1613
1614END FUNCTION trim_byte_to_char_miss
1615
1616
1617! Version with character argument, please use the generic \a to_char
1618! rather than this function directly. It is almost useless, just
1619! provided for completeness.
1620ELEMENTAL FUNCTION char_to_char(in) RESULT(char)
1621CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1622CHARACTER(len=LEN(in)) :: char
1623
1624char = in
1625
1626END FUNCTION char_to_char
1627
1628
1629ELEMENTAL FUNCTION char_to_char_miss(in, miss) RESULT(char)
1630CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1631CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1632CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
1633
1634IF (c_e(in)) THEN
1635 char = in
1636ELSE
1637 char = miss
1638ENDIF
1639
1640END FUNCTION char_to_char_miss
1641
1642
1643FUNCTION trim_char_to_char(in) result(char)
1644CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1645CHARACTER(len=LEN_TRIM(in)) :: char
1646
1647char = trim(in)
1648
1649END FUNCTION trim_char_to_char
1650
1651
1652FUNCTION trim_char_to_char_miss(in, miss) RESULT(char)
1653CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1654CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing valu
1655CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
1656
1657char = char_to_char_miss(in, miss)
1658
1659END FUNCTION trim_char_to_char_miss
1660
1661
1662! Version with single precision real argument, please use the generic
1663! \a to_char rather than this function directly.
1664ELEMENTAL FUNCTION real_to_char(in, miss, form) RESULT(char)
1665REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1666CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1667CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1668CHARACTER(len=15) :: char
1669
1670CHARACTER(len=15) :: tmpchar
1671
1672IF (PRESENT(miss)) THEN
1673 IF (.NOT.c_e(in)) THEN
1674 char = miss
1675 ELSE
1676 IF (PRESENT(form)) THEN
1677 WRITE(char,form)in
1678 ELSE
1679 WRITE(tmpchar,'(G15.9)') in
1680 char = adjustl(tmpchar)
1681 ENDIF
1682 ENDIF
1683ELSE
1684 IF (PRESENT(form)) THEN
1685 WRITE(char,form)in
1686 ELSE
1687 WRITE(tmpchar,'(G15.9)') in
1688 char = adjustl(tmpchar)
1689 ENDIF
1690ENDIF
1691
1692END FUNCTION real_to_char
1693
1694
1695FUNCTION trim_real_to_char(in) RESULT(char)
1696REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1697CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1698
1699char = real_to_char(in)
1700
1701END FUNCTION trim_real_to_char
1702
1703
1704FUNCTION trim_real_to_char_miss(in, miss) RESULT(char)
1705REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1706CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1707CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1708
1709char = real_to_char(in, miss=miss)
1710
1711END FUNCTION trim_real_to_char_miss
1712
1713
1714! Version with double precision real argument, please use the generic
1715! \a to_char rather than this function directly.
1716ELEMENTAL FUNCTION double_to_char(in, miss, form) RESULT(char)
1717DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1718CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1719CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1720CHARACTER(len=24) :: char
1721
1722CHARACTER(len=24) :: tmpchar
1723
1724IF (PRESENT(miss)) THEN
1725 IF (.NOT.c_e(in)) THEN
1726 char = miss
1727 ELSE
1728 IF (PRESENT(form)) THEN
1729 WRITE(char,form)in
1730 ELSE
1731 WRITE(tmpchar,'(G24.17)') in
1732 char = adjustl(tmpchar)
1733 ENDIF
1734 ENDIF
1735ELSE
1736 IF (PRESENT(form)) THEN
1737 WRITE(char,form)in
1738 ELSE
1739 WRITE(tmpchar,'(G24.17)') in
1740 char = adjustl(tmpchar)
1741 ENDIF
1742ENDIF
1743
1744END FUNCTION double_to_char
1745
1746
1747FUNCTION trim_double_to_char(in) RESULT(char)
1748DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1749CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1750
1751char=double_to_char(in)
1752
1753END FUNCTION trim_double_to_char
1754
1755
1756FUNCTION trim_double_to_char_miss(in, miss) RESULT(char)
1757DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1758CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1759CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1760
1761char=double_to_char(in, miss=miss)
1762
1763END FUNCTION trim_double_to_char_miss
1764
1765
1766! Version with logical argument, please use the generic \a to_char
1767! rather than this function directly.
1768ELEMENTAL FUNCTION logical_to_char(in, form) RESULT(char)
1769LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1770CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1771CHARACTER(len=1) :: char
1772
1773IF (PRESENT(form)) THEN
1774 WRITE(char,form) in
1775ELSE
1776 WRITE(char,'(L1)') in
1777ENDIF
1778
1779END FUNCTION logical_to_char
1780
1781
1782ELEMENTAL FUNCTION trim_logical_to_char(in) RESULT(char)
1783LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1784
1785CHARACTER(len=1) :: char
1786
1787WRITE(char,'(L1)') in
1788
1789END FUNCTION trim_logical_to_char
1790
1791
1796ELEMENTAL FUNCTION c2i(string) RESULT(num)
1797CHARACTER(len=*),INTENT(in) :: string
1798INTEGER :: num
1799
1800INTEGER :: lier
1801
1802IF (.NOT.c_e(string)) THEN
1803 num = imiss
1804ELSE IF (len_trim(string) == 0) THEN
1805 num = imiss
1806ELSE
1807 READ(string, '(I32)', iostat=lier)num
1808 IF (lier /= 0) THEN
1809 num = imiss
1810 ENDIF
1811ENDIF
1812
1813END FUNCTION c2i
1814
1815
1820ELEMENTAL FUNCTION c2r(string) RESULT(num)
1821CHARACTER(len=*),INTENT(in) :: string
1822REAL :: num
1823
1824INTEGER :: lier
1825
1826IF (.NOT.c_e(string)) THEN
1827 num = rmiss
1828ELSE IF (len_trim(string) == 0) THEN
1829 num = rmiss
1830ELSE
1831 READ(string, '(F32.0)', iostat=lier)num
1832 IF (lier /= 0) THEN
1833 num = rmiss
1834 ENDIF
1835ENDIF
1836
1837END FUNCTION c2r
1838
1839
1844ELEMENTAL FUNCTION c2d(string) RESULT(num)
1845CHARACTER(len=*),INTENT(in) :: string
1846DOUBLE PRECISION :: num
1847
1848INTEGER :: lier
1849
1850IF (.NOT.c_e(string)) THEN
1851 num = rmiss
1852ELSE IF (len_trim(string) == 0) THEN
1853 num = rmiss
1854ELSE
1855 READ(string, '(F32.0)', iostat=lier)num
1856 IF (lier /= 0) THEN
1857 num = rmiss
1858 ENDIF
1859ENDIF
1860
1861END FUNCTION c2d
1862
1863
1869FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
1870CHARACTER(len=*), INTENT(in) :: fchar
1871INTEGER(kind=int_b) :: cstr(LEN(fchar)+1)
1872
1873cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
1874cstr(len(fchar)+1) = 0 ! zero-terminate
1875
1876END FUNCTION fchar_to_cstr
1877
1878
1884SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
1885CHARACTER(len=*), INTENT(in) :: fchar
1886INTEGER(kind=int_b), POINTER :: pcstr(:)
1887
1888ALLOCATE(pcstr(len(fchar)+1))
1889pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
1890pcstr(len(fchar)+1) = 0 ! zero-terminate
1891
1892END SUBROUTINE fchar_to_cstr_alloc
1893
1894
1898FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
1899INTEGER(kind=int_b), INTENT(in) :: cstr(:)
1900CHARACTER(len=SIZE(cstr)-1) :: fchar
1901
1902INTEGER :: i
1903
1904!l = MIN(LEN(char), SIZE(cstr)-1)
1905fchar = transfer(cstr(1:SIZE(cstr)-1), fchar)
1906DO i = 1, SIZE(cstr)-1
1907 IF (fchar(i:i) == char(0)) THEN ! truncate if the null terminator is found before
1908 fchar(i:) = ' '
1909 EXIT
1910 ENDIF
1911ENDDO
1912
1913END FUNCTION cstr_to_fchar
1914
1915
1917FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
1918CHARACTER( * ), INTENT( IN ) :: Input_String
1919CHARACTER( LEN( Input_String ) ) :: Output_String
1920 ! -- Local variables
1921INTEGER :: i, n
1922
1923 ! -- Copy input string
1924output_string = input_string
1925 ! -- Loop over string elements
1926DO i = 1, len( output_string )
1927 ! -- Find location of letter in lower case constant string
1928 n = index( lower_case, output_string( i:i ) )
1929 ! -- If current substring is a lower case letter, make it upper case
1930 IF ( n /= 0 ) output_string( i:i ) = upper_case( n:n )
1931END DO
1932END FUNCTION uppercase
1933
1934
1936FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
1937 ! -- Argument and result
1938CHARACTER( * ), INTENT( IN ) :: Input_String
1939CHARACTER( LEN( Input_String ) ) :: Output_String
1940 ! -- Local variables
1941INTEGER :: i, n
1942
1943 ! -- Copy input string
1944output_string = input_string
1945 ! -- Loop over string elements
1946DO i = 1, len( output_string )
1947 ! -- Find location of letter in upper case constant string
1948 n = index( upper_case, output_string( i:i ) )
1949 ! -- If current substring is an upper case letter, make it lower case
1950 IF ( n /= 0 ) output_string( i:i ) = lower_case( n:n )
1951END DO
1952END FUNCTION lowercase
1953
1954
1960ELEMENTAL FUNCTION align_center(input_string) RESULT(aligned)
1961CHARACTER(len=*), INTENT(in) :: input_string
1962
1963CHARACTER(len=LEN(input_string)) :: aligned
1964
1965INTEGER :: n1, n2
1966
1967n1 = f_nblnk(input_string)
1968n2 = len(input_string)-l_nblnk(input_string)+1
1969
1970aligned = ''
1971aligned((n1+n2)/2:) = input_string(n1:)
1972
1973END FUNCTION align_center
1974
1975
1981ELEMENTAL FUNCTION l_nblnk(input_string, blnk) RESULT(nblnk)
1982CHARACTER(len=*), INTENT(in) :: input_string
1983CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk
1984
1985CHARACTER(len=1) :: lblnk
1986INTEGER :: nblnk
1987
1988IF (PRESENT(blnk)) THEN
1989 lblnk = blnk
1990ELSE
1991 lblnk = ' '
1992ENDIF
1993
1994DO nblnk = len(input_string), 1, -1
1995 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
1996ENDDO
1997
1998END FUNCTION l_nblnk
1999
2000
2004ELEMENTAL FUNCTION f_nblnk(input_string, blnk) RESULT(nblnk)
2005CHARACTER(len=*), INTENT(in) :: input_string
2006CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk
2007
2008CHARACTER(len=1) :: lblnk
2009INTEGER :: nblnk
2010
2011IF (PRESENT(blnk)) THEN
2012 lblnk = blnk
2013ELSE
2014 lblnk = ' '
2015ENDIF
2016
2017DO nblnk = 1, len(input_string)
2018 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
2019ENDDO
2020
2021END FUNCTION f_nblnk
2022
2023
2030FUNCTION word_split(input_string, word_start, word_end, sep) RESULT(nword)
2031CHARACTER(len=*), INTENT(in) :: input_string
2032INTEGER, POINTER, OPTIONAL :: word_start(:)
2033INTEGER, POINTER, OPTIONAL :: word_end(:)
2034CHARACTER(len=1), OPTIONAL :: sep
2035
2036INTEGER :: nword
2037
2038INTEGER :: ls, le
2039INTEGER, POINTER :: lsv(:), lev(:)
2040CHARACTER(len=1) :: lsep
2041
2042IF (PRESENT(sep)) THEN
2043 lsep = sep
2044ELSE
2045 lsep = ' '
2046ENDIF
2047
2048nword = 0
2049le = 0
2050DO WHILE(.true.)
2051 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2052 IF (ls > len(input_string)) EXIT ! end of words
2053 le = index(input_string(ls:), lsep)
2054 IF (le == 0) THEN
2055 le = len(input_string)
2056 ELSE
2057 le = le + ls - 2
2058 ENDIF
2059 nword = nword + 1
2060ENDDO
2061
2062IF (.NOT.PRESENT(word_start) .AND. .NOT.PRESENT(word_end)) RETURN
2063
2064ALLOCATE(lsv(nword), lev(nword))
2065nword = 0
2066le = 0
2067DO WHILE(.true.)
2068 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2069 IF (ls > len(input_string)) EXIT ! end of words
2070 le = index(input_string(ls:), lsep)
2071 IF (le == 0) THEN
2072 le = len(input_string)
2073 ELSE
2074 le = le + ls - 2
2075 ENDIF
2076 nword = nword + 1
2077 lsv(nword) = ls
2078 lev(nword) = le
2079ENDDO
2080
2081IF (PRESENT(word_start)) THEN
2082 word_start => lsv
2083ELSE
2084 DEALLOCATE(lsv)
2085ENDIF
2086IF (PRESENT(word_end)) THEN
2087 word_end => lev
2088ELSE
2089 DEALLOCATE(lev)
2090ENDIF
2091
2092END FUNCTION word_split
2093
2094
2099FUNCTION line_split_new(line, ncols) RESULT(this)
2100CHARACTER(len=*), INTENT(in) :: line
2101INTEGER, INTENT(in), OPTIONAL :: ncols
2102
2103TYPE(line_split) :: this
2104
2105INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
2106
2107IF (PRESENT(ncols)) THEN
2108 this%ncols = ncols
2109ELSE
2110 this%ncols = default_columns()
2111ENDIF
2112! split the input line
2113nwords = word_split(line, this%word_start, this%word_end)
2114! count the lines required to accomodate the input line in a paragraph
2115nlines = 0
2116nw = 0
2117DO WHILE(nw < nwords)
2118 columns_in_line = 0
2119 words_in_line = 0
2120 DO WHILE(nw < nwords)
2121 nw = nw + 1
2122 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2123 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2124 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2125 words_in_line == 0) THEN ! accept the word
2126 columns_in_line = columns_in_line + ncols_next_word
2127 words_in_line = words_in_line + 1
2128 ELSE ! refuse the word
2129 nw = nw - 1
2130 EXIT
2131 ENDIF
2132 ENDDO
2133 nlines = nlines + 1
2134ENDDO
2135
2136!IF (nlines == 0)
2137ALLOCATE(this%paragraph(this%ncols, nlines))
2138this%paragraph = ' '
2139! repeat filling the paragraph
2140nlines = 0
2141nw = 0
2142DO WHILE(nw < nwords)
2143 columns_in_line = 0
2144 words_in_line = 0
2145 DO WHILE(nw < nwords)
2146 nw = nw + 1
2147 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2148 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2149 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2150 words_in_line == 0) THEN ! accept the word
2151 columns_in_line = columns_in_line + ncols_next_word
2152! now fill the paragraph
2153 IF (columns_in_line <= this%ncols) THEN ! non truncated line
2154 IF (words_in_line > 0) THEN ! previous space
2155 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2156 transfer(' '//line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2157 ELSE ! no previous space
2158 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2159 transfer(line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2160 ENDIF
2161 ELSE ! truncated line (word longer than line)
2162 this%paragraph(1:this%ncols,nlines+1) = &
2163 transfer(line(this%word_start(nw):this%word_start(nw)+this%ncols-1), this%paragraph)
2164 ENDIF
2165 words_in_line = words_in_line + 1
2166 ELSE ! refuse the word
2167 nw = nw - 1
2168 EXIT
2169 ENDIF
2170 ENDDO
2171 nlines = nlines + 1
2172ENDDO
2173
2174END FUNCTION line_split_new
2175
2176
2177! Cleanly destroy a \a line_split object, deallocating all the
2178! dynamically allocated space. Use the generic name \a delete rather
2179! than this specfoc subroutine.
2180SUBROUTINE line_split_delete(this)
2181TYPE(line_split), INTENT(inout) :: this ! object to be destroyed
2182
2183IF (ASSOCIATED(this%paragraph)) DEALLOCATE(this%paragraph)
2184IF (ASSOCIATED(this%word_start)) DEALLOCATE(this%word_start)
2185IF (ASSOCIATED(this%word_end)) DEALLOCATE(this%word_end)
2186
2187END SUBROUTINE line_split_delete
2188
2189
2191FUNCTION line_split_get_nlines(this) RESULT(nlines)
2192TYPE(line_split), INTENT(in) :: this
2193
2194INTEGER :: nlines
2195
2196IF (ASSOCIATED(this%paragraph)) THEN
2197 nlines = SIZE(this%paragraph, 2)
2198ELSE
2199 nlines = 0
2200ENDIF
2201
2202END FUNCTION line_split_get_nlines
2203
2204
2209FUNCTION line_split_get_line(this, nline) RESULT(line)
2210TYPE(line_split), INTENT(in) :: this
2211INTEGER, INTENT(in) :: nline
2212
2213CHARACTER(len=SIZE(this%paragraph, 1)) :: line
2214IF (nline > 0 .AND. nline <= SIZE(this%paragraph, 2)) THEN
2215 line = transfer(this%paragraph(:,nline), line)
2216ELSE
2217 line = cmiss
2218ENDIF
2219
2220END FUNCTION line_split_get_line
2221
2222
2228FUNCTION default_columns() RESULT(cols)
2229INTEGER :: cols
2230
2231INTEGER, PARAMETER :: defaultcols = 80 ! default of the defaults
2232INTEGER, PARAMETER :: maxcols = 256 ! maximum value
2233CHARACTER(len=10) :: ccols
2234
2235cols = defaultcols
2236CALL getenv('COLUMNS', ccols)
2237IF (ccols == '') RETURN
2238
2239READ(ccols, '(I10)', err=100) cols
2240cols = min(cols, maxcols)
2241IF (cols <= 0) cols = defaultcols
2242RETURN
2243
2244100 cols = defaultcols ! error in reading the value
2245
2246END FUNCTION default_columns
2247
2248
2250FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
2251! -- Argument and result
2252CHARACTER( * ), INTENT( IN ) :: Input_String
2253CHARACTER( LEN( Input_String ) ) :: Output_String
2254! -- Local variables
2255INTEGER :: i
2256
2257output_string=""
2258i = index(input_string,".",back=.true.)
2259if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
2260
2261END FUNCTION suffixname
2262
2263
2270ELEMENTAL FUNCTION wash_char(in, goodchar, badchar) RESULT(char)
2271CHARACTER(len=*),INTENT(in) :: in
2272CHARACTER(len=*),INTENT(in),OPTIONAL :: badchar
2273CHARACTER(len=*),INTENT(in),OPTIONAL :: goodchar
2274integer,allocatable :: igoodchar(:)
2275integer,allocatable :: ibadchar(:)
2276
2277CHARACTER(len=len(in)) :: char,charr,charrr
2278INTEGER :: i,ia,nchar
2279
2280char=""
2281charr=""
2282charrr=""
2283
2284if (present(goodchar)) then
2285
2286allocate(igoodchar(len(goodchar)))
2287
2288 do i =1, len(goodchar)
2289 igoodchar=ichar(goodchar(i:i))
2290 end do
2291
2292 nchar=0
2293 do i=1,len(in)
2294 ia = ichar(in(i:i))
2295 if (any(ia == igoodchar))then
2296 nchar=nchar+1
2297 charrr(nchar:nchar)=achar(ia)
2298 end if
2299 end do
2300
2301deallocate(igoodchar)
2302
2303else
2304
2305 charrr=in
2306
2307end if
2308
2309
2310
2311if (present(badchar)) then
2312
2313allocate(ibadchar(len(badchar)))
2314
2315 do i =1, len(badchar)
2316 ibadchar=ichar(badchar(i:i))
2317 end do
2318
2319 nchar=0
2320 do i=1,len(charrr)
2321 ia = ichar(charrr(i:i))
2322 if (.not. any(ia == ibadchar))then
2323 nchar=nchar+1
2324 charr(nchar:nchar)=achar(ia)
2325 end if
2326 end do
2327
2328deallocate(ibadchar)
2329
2330else
2331
2332 charr=charrr
2333
2334end if
2335
2336
2337if (.not. present(goodchar) .and. .not. present(badchar)) then
2338
2339 nchar=0
2340 do i=1,len(charr)
2341 ia = ichar(charr(i:i))
2342 if ((ia >= 65 .and. ia <= 90) .or. &
2343 (ia >= 97 .and. ia <= 122))then
2344 nchar=nchar+1
2345 char(nchar:nchar)=achar(ia)
2346 end if
2347 end do
2348
2349else
2350
2351 char=charr
2352
2353end if
2354
2355
2356END FUNCTION wash_char
2357
2358
2359! derived by http://sourceforge.net/projects/flibs
2360!
2361! globmatch.f90 --
2362! Match strings according to (simplified) glob patterns
2363!
2364! The pattern matching is limited to literals, * and ?
2365! (character classes are not supported). A backslash escapes
2366! any character.
2367!
2368! $Id: globmatch.f90,v 1.5 2006/03/26 19:03:53 arjenmarkus Exp $
2369!!$Copyright (c) 2008, Arjen Markus
2370!!$
2371!!$All rights reserved.
2372!!$
2373!!$Redistribution and use in source and binary forms, with or without modification,
2374!!$are permitted provided that the following conditions are met:
2375!!$
2376!!$Redistributions of source code must retain the above copyright notice,
2377!!$this list of conditions and the following disclaimer.
2378!!$Redistributions in binary form must reproduce the above copyright notice,
2379!!$this list of conditions and the following disclaimer in the documentation
2380!!$and/or other materials provided with the distribution.
2381!!$Neither the name of the author nor the names of the contributors
2382!!$may be used to endorse or promote products derived from this software
2383!!$without specific prior written permission.
2384!!$THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2385!!$"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
2386!!$THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
2387!!$ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
2388!!$FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
2389!!$DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
2390!!$SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2391!!$CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
2392!!$OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
2393!!$OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2394!
2395
2399function string_match_v( string, pattern ) result(match)
2400character(len=*), intent(in) :: string(:)
2401character(len=*), intent(in) :: pattern
2402logical :: match(size(string))
2403
2404integer :: i
2405
2406do i =1,size(string)
2407 match(i)=string_match(string(i),pattern)
2408end do
2409
2410end function string_match_v
2411
2412
2416recursive function string_match( string, pattern ) result(match)
2417 character(len=*), intent(in) :: string
2418 character(len=*), intent(in) :: pattern
2419 logical :: match
2420
2421! '\\' without -fbackslash generates a warning on gfortran, '\'
2422! crashes doxygen, so we choose '\\' and -fbackslash in configure.ac
2423 character(len=1), parameter :: backslash = '\\'
2424 character(len=1), parameter :: star = '*'
2425 character(len=1), parameter :: question = '?'
2426
2427 character(len=len(pattern)) :: literal
2428 integer :: ptrim
2429 integer :: p
2430 integer :: k
2431 integer :: ll
2432 integer :: method
2433 integer :: start
2434 integer :: strim
2435
2436 match = .false.
2437 method = 0
2438 ptrim = len_trim( pattern )
2439 strim = len_trim( string )
2440 p = 1
2441 ll = 0
2442 start = 1
2443
2444 !
2445 ! Split off a piece of the pattern
2446 !
2447 do while ( p <= ptrim )
2448 select case ( pattern(p:p) )
2449 case( star )
2450 if ( ll .ne. 0 ) exit
2451 method = 1
2452 case( question )
2453 if ( ll .ne. 0 ) exit
2454 method = 2
2455 start = start + 1
2456 case( backslash )
2457 p = p + 1
2458 ll = ll + 1
2459 literal(ll:ll) = pattern(p:p)
2460 case default
2461 ll = ll + 1
2462 literal(ll:ll) = pattern(p:p)
2463 end select
2464
2465 p = p + 1
2466 enddo
2467
2468 !
2469 ! Now look for the literal string (if any!)
2470 !
2471 if ( method == 0 ) then
2472 !
2473 ! We are at the end of the pattern, and of the string?
2474 !
2475 if ( strim == 0 .and. ptrim == 0 ) then
2476 match = .true.
2477 else
2478 !
2479 ! The string matches a literal part?
2480 !
2481 if ( ll > 0 ) then
2482 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2483 start = start + ll
2484 match = string_match( string(start:), pattern(p:) )
2485 endif
2486 endif
2487 endif
2488 endif
2489
2490 if ( method == 1 ) then
2491 !
2492 ! Scan the whole of the remaining string ...
2493 !
2494 if ( ll == 0 ) then
2495 match = .true.
2496 else
2497 do while ( start <= strim )
2498 k = index( string(start:), literal(1:ll) )
2499 if ( k > 0 ) then
2500 start = start + k + ll - 1
2501 match = string_match( string(start:), pattern(p:) )
2502 if ( match ) then
2503 exit
2504 endif
2505 endif
2506
2507 start = start + 1
2508 enddo
2509 endif
2510 endif
2511
2512 if ( method == 2 .and. ll > 0 ) then
2513 !
2514 ! Scan the whole of the remaining string ...
2515 !
2516 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2517 match = string_match( string(start+ll:), pattern(p:) )
2518 endif
2519 endif
2520 return
2521end function string_match
2522
2523
2524SUBROUTINE print_status_line(line)
2525CHARACTER(len=*),INTENT(in) :: line
2526CHARACTER(len=1),PARAMETER :: cr=char(13)
2527WRITE(stdout_unit,'(2A)',advance='no')cr,trim(line)
2528FLUSH(unit=6) ! probably useless with gfortran, required with Intel fortran
2529END SUBROUTINE print_status_line
2530
2531SUBROUTINE done_status_line()
2532WRITE(stdout_unit,'()')
2533END SUBROUTINE done_status_line
2534
2535
2544SUBROUTINE progress_line_update_d(this, val)
2545CLASS(progress_line),INTENT(inout) :: this
2546DOUBLE PRECISION,INTENT(in) :: val
2547
2548INTEGER :: vint, i
2549CHARACTER(len=512) :: line
2550
2551IF (this%curr >= this%max) RETURN ! line is already closed, do nothing
2552
2553this%curr = max(this%min, min(this%max, val))
2554this%spin = mod(this%spin+1, 4)
2555line = ''
2556
2557vint = nint((this%curr-this%min)/(this%max-this%min)*100.d0)
2558WRITE(line,this%form)vint, &
2559 progress_line_spin(this%spin+1:this%spin+1)
2560vint = vint/10
2561
2562DO i = 1, vint
2563 line(this%barloc+i:this%barloc+i) = this%done
2564ENDDO
2565DO i = vint+1, 10
2566 line(this%barloc+i:this%barloc+i) = this%todo
2567ENDDO
2568CALL print_status_line(line)
2569IF (this%curr >= this%max) CALL done_status_line()
2570
2571END SUBROUTINE progress_line_update_d
2572
2573
2578SUBROUTINE progress_line_update_i(this, val)
2579CLASS(progress_line),INTENT(inout) :: this
2580INTEGER,INTENT(in) :: val
2581
2582CALL progress_line_update_d(this, dble(val))
2583
2584END SUBROUTINE progress_line_update_i
2585
2591SUBROUTINE progress_line_alldone(this)
2592CLASS(progress_line),INTENT(inout) :: this
2593CALL progress_line_update_d(this, this%max)
2594END SUBROUTINE progress_line_alldone
2595
2596
2597END MODULE char_utilities
Destructor for the line_split class.
Tries to match the given string with the pattern Result: .true.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Index method.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Definition of constants related to I/O units.
Definition: io_units.F90:225
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:245
Definitions of constants and functions for working with missing values.
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Class to print a progress bar on the screen.

Generated with Doxygen.