libsim Versione 7.1.11

◆ 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 1308 del file char_utilities.F90.

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