libsim Versione 7.1.11

◆ progress_line_update_d()

subroutine progress_line_update_d ( class(progress_line), intent(inout)  this,
double precision, intent(in)  val 
)
private

Update a progress line with a new value.

This subroutine updates the progress line object with a new double precision value val. Values outside the range thismin, thismax are truncated. If val is equal or greter maximum the progress bar is closed so that a new line can be printed. When a progress_line object reaches its maximum it can no more be updated and/or closed. Use the interface method update rather than this subroutine directly.

Parametri
[in,out]thisprogress_line object to be updated
[in]valnew value

Definizione alla linea 1436 del file char_utilities.F90.

1437! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1438! authors:
1439! Davide Cesari <dcesari@arpa.emr.it>
1440! Paolo Patruno <ppatruno@arpa.emr.it>
1441
1442! This program is free software; you can redistribute it and/or
1443! modify it under the terms of the GNU General Public License as
1444! published by the Free Software Foundation; either version 2 of
1445! the License, or (at your option) any later version.
1446
1447! This program is distributed in the hope that it will be useful,
1448! but WITHOUT ANY WARRANTY; without even the implied warranty of
1449! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1450! GNU General Public License for more details.
1451
1452! You should have received a copy of the GNU General Public License
1453! along with this program. If not, see <http://www.gnu.org/licenses/>.
1460#include "config.h"
1461MODULE char_utilities
1462USE kinds
1464USE io_units
1465IMPLICIT NONE
1466
1467CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
1468CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1469
1501INTERFACE to_char
1502 MODULE PROCEDURE int_to_char, byte_to_char, &
1503 real_to_char, double_to_char, logical_to_char, &
1504 char_to_char, char_to_char_miss
1505END INTERFACE
1506
1507
1526INTERFACE t2c
1527 MODULE PROCEDURE trim_int_to_char, trim_int_to_char_miss, &
1528 trim_byte_to_char, trim_byte_to_char_miss, &
1529 trim_real_to_char, trim_real_to_char_miss, &
1530 trim_double_to_char, trim_double_to_char_miss, trim_logical_to_char, &
1531 trim_char_to_char, trim_char_to_char_miss
1532END INTERFACE
1533
1534
1539TYPE line_split
1540 PRIVATE
1541 INTEGER :: align_type, ncols, nlines
1542 INTEGER, POINTER :: word_start(:), word_end(:)
1543 CHARACTER(len=1), POINTER :: paragraph(:,:)
1544END TYPE line_split
1545
1551INTERFACE delete
1552 MODULE PROCEDURE line_split_delete
1553END INTERFACE
1554
1555
1616INTERFACE match
1617 MODULE PROCEDURE string_match, string_match_v
1618END INTERFACE
1619
1620
1628TYPE progress_line
1629 DOUBLE PRECISION :: min=0.0d0
1630 DOUBLE PRECISION :: max=100.0d0
1631 DOUBLE PRECISION,PRIVATE :: curr=0.0d0
1632 CHARACTER(len=512),PRIVATE :: form='(''|'',I3.0,''%|'',A,''|'',10X,''|'')'
1633 CHARACTER(len=1),PRIVATE :: done='='
1634 CHARACTER(len=1),PRIVATE :: todo='-'
1635 INTEGER,PRIVATE :: barloc=8
1636 INTEGER,PRIVATE :: spin=0
1637 CONTAINS
1638 PROCEDURE :: update => progress_line_update_d, progress_line_update_i
1639 PROCEDURE :: alldone => progress_line_alldone
1640END TYPE progress_line
1641
1642CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
1643
1644PRIVATE
1645PUBLIC line_split
1646PUBLIC to_char, t2c, c2i, c2r, c2d, delete, match, &
1647 fchar_to_cstr, fchar_to_cstr_alloc, cstr_to_fchar, uppercase, lowercase, &
1648 align_center, l_nblnk, f_nblnk, word_split, &
1649 line_split_new, line_split_get_nlines, line_split_get_line, &
1650 suffixname, default_columns, wash_char, &
1651 print_status_line, done_status_line, progress_line
1652
1653CONTAINS
1654
1655! Version with integer argument, please use the generic \a to_char
1656! rather than this function directly.
1657ELEMENTAL FUNCTION int_to_char(in, miss, form) RESULT(char)
1658INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1659CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1660CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1661CHARACTER(len=11) :: char
1662
1663IF (PRESENT(miss)) THEN
1664 IF (.NOT.c_e(in)) THEN
1665 char = miss
1666 ELSE
1667 IF (PRESENT(form)) THEN
1668 WRITE(char,form)in
1669 ELSE
1670 WRITE(char,'(I0)')in
1671 ENDIF
1672 ENDIF
1673ELSE
1674 IF (PRESENT(form)) THEN
1675 WRITE(char,form)in
1676 ELSE
1677 WRITE(char,'(I0)')in
1678 ENDIF
1679ENDIF
1680
1681END FUNCTION int_to_char
1682
1683
1684FUNCTION trim_int_to_char(in) RESULT(char)
1685INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1686CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1687
1688char = to_char(in)
1689
1690END FUNCTION trim_int_to_char
1691
1692
1693FUNCTION trim_int_to_char_miss(in, miss) RESULT(char)
1694INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1695CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1696CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1697
1698char = to_char(in, miss=miss)
1699
1700END FUNCTION trim_int_to_char_miss
1701
1702
1703! Version with 1-byte integer argument, please use the generic \a to_char
1704! rather than this function directly.
1705ELEMENTAL FUNCTION byte_to_char(in, miss, form) RESULT(char)
1706INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1707CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1708CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1709CHARACTER(len=11) :: char
1710
1711IF (PRESENT(miss)) THEN
1712 IF (.NOT.c_e(in)) THEN
1713 char = miss
1714 ELSE
1715 IF (PRESENT(form)) THEN
1716 WRITE(char,form)in
1717 ELSE
1718 WRITE(char,'(I0)')in
1719 ENDIF
1720 ENDIF
1721ELSE
1722 IF (PRESENT(form)) THEN
1723 WRITE(char,form)in
1724 ELSE
1725 WRITE(char,'(I0)')in
1726 ENDIF
1727ENDIF
1728
1729END FUNCTION byte_to_char
1730
1731
1732FUNCTION trim_byte_to_char(in) RESULT(char)
1733INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1734CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1735
1736char = to_char(in)
1737
1738END FUNCTION trim_byte_to_char
1739
1740
1741FUNCTION trim_byte_to_char_miss(in,miss) RESULT(char)
1742INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1743CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1744CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1745
1746char = to_char(in, miss=miss)
1747
1748END FUNCTION trim_byte_to_char_miss
1749
1750
1751! Version with character argument, please use the generic \a to_char
1752! rather than this function directly. It is almost useless, just
1753! provided for completeness.
1754elemental_unlessxlf FUNCTION char_to_char(in) RESULT(char)
1755CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1756CHARACTER(len=LEN(in)) :: char
1757
1758char = in
1759
1760END FUNCTION char_to_char
1761
1762
1763elemental_unlessxlf FUNCTION char_to_char_miss(in, miss) RESULT(char)
1764CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1765CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1766CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
1767
1768IF (c_e(in)) THEN
1769 char = in
1770ELSE
1771 char = miss
1772ENDIF
1773
1774END FUNCTION char_to_char_miss
1775
1776
1777FUNCTION trim_char_to_char(in) result(char)
1778CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1779CHARACTER(len=LEN_TRIM(in)) :: char
1780
1781char = trim(in)
1782
1783END FUNCTION trim_char_to_char
1784
1785
1786FUNCTION trim_char_to_char_miss(in, miss) RESULT(char)
1787CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1788CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing valu
1789CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
1790
1791char = char_to_char_miss(in, miss)
1792
1793END FUNCTION trim_char_to_char_miss
1794
1795
1796! Version with single precision real argument, please use the generic
1797! \a to_char rather than this function directly.
1798ELEMENTAL FUNCTION real_to_char(in, miss, form) RESULT(char)
1799REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1800CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1801CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1802CHARACTER(len=15) :: char
1803
1804CHARACTER(len=15) :: tmpchar
1805
1806IF (PRESENT(miss)) THEN
1807 IF (.NOT.c_e(in)) THEN
1808 char = miss
1809 ELSE
1810 IF (PRESENT(form)) THEN
1811 WRITE(char,form)in
1812 ELSE
1813 WRITE(tmpchar,'(G15.9)') in
1814 char = adjustl(tmpchar)
1815 ENDIF
1816 ENDIF
1817ELSE
1818 IF (PRESENT(form)) THEN
1819 WRITE(char,form)in
1820 ELSE
1821 WRITE(tmpchar,'(G15.9)') in
1822 char = adjustl(tmpchar)
1823 ENDIF
1824ENDIF
1825
1826END FUNCTION real_to_char
1827
1828
1829FUNCTION trim_real_to_char(in) RESULT(char)
1830REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1831CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1832
1833char = real_to_char(in)
1834
1835END FUNCTION trim_real_to_char
1836
1837
1838FUNCTION trim_real_to_char_miss(in, miss) RESULT(char)
1839REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1840CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1841CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1842
1843char = real_to_char(in, miss=miss)
1844
1845END FUNCTION trim_real_to_char_miss
1846
1847
1848! Version with double precision real argument, please use the generic
1849! \a to_char rather than this function directly.
1850ELEMENTAL FUNCTION double_to_char(in, miss, form) RESULT(char)
1851DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1852CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1853CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1854CHARACTER(len=24) :: char
1855
1856CHARACTER(len=24) :: tmpchar
1857
1858IF (PRESENT(miss)) THEN
1859 IF (.NOT.c_e(in)) THEN
1860 char = miss
1861 ELSE
1862 IF (PRESENT(form)) THEN
1863 WRITE(char,form)in
1864 ELSE
1865 WRITE(tmpchar,'(G24.17)') in
1866 char = adjustl(tmpchar)
1867 ENDIF
1868 ENDIF
1869ELSE
1870 IF (PRESENT(form)) THEN
1871 WRITE(char,form)in
1872 ELSE
1873 WRITE(tmpchar,'(G24.17)') in
1874 char = adjustl(tmpchar)
1875 ENDIF
1876ENDIF
1877
1878END FUNCTION double_to_char
1879
1880
1881FUNCTION trim_double_to_char(in) RESULT(char)
1882DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1883CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1884
1885char=double_to_char(in)
1886
1887END FUNCTION trim_double_to_char
1888
1889
1890FUNCTION trim_double_to_char_miss(in, miss) RESULT(char)
1891DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1892CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1893CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1894
1895char=double_to_char(in, miss=miss)
1896
1897END FUNCTION trim_double_to_char_miss
1898
1899
1900! Version with logical argument, please use the generic \a to_char
1901! rather than this function directly.
1902ELEMENTAL FUNCTION logical_to_char(in, form) RESULT(char)
1903LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1904CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1905CHARACTER(len=1) :: char
1906
1907IF (PRESENT(form)) THEN
1908 WRITE(char,form) in
1909ELSE
1910 WRITE(char,'(L1)') in
1911ENDIF
1912
1913END FUNCTION logical_to_char
1914
1915
1916ELEMENTAL FUNCTION trim_logical_to_char(in) RESULT(char)
1917LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1918
1919CHARACTER(len=1) :: char
1920
1921WRITE(char,'(L1)') in
1922
1923END FUNCTION trim_logical_to_char
1924
1925
1930ELEMENTAL FUNCTION c2i(string) RESULT(num)
1931CHARACTER(len=*),INTENT(in) :: string
1932INTEGER :: num
1933
1934INTEGER :: lier
1935
1936IF (.NOT.c_e(string)) THEN
1937 num = imiss
1938ELSE IF (len_trim(string) == 0) THEN
1939 num = imiss
1940ELSE
1941 READ(string, '(I32)', iostat=lier)num
1942 IF (lier /= 0) THEN
1943 num = imiss
1944 ENDIF
1945ENDIF
1946
1947END FUNCTION c2i
1948
1949
1954ELEMENTAL FUNCTION c2r(string) RESULT(num)
1955CHARACTER(len=*),INTENT(in) :: string
1956REAL :: num
1957
1958INTEGER :: lier
1959
1960IF (.NOT.c_e(string)) THEN
1961 num = rmiss
1962ELSE IF (len_trim(string) == 0) THEN
1963 num = rmiss
1964ELSE
1965 READ(string, '(F32.0)', iostat=lier)num
1966 IF (lier /= 0) THEN
1967 num = rmiss
1968 ENDIF
1969ENDIF
1970
1971END FUNCTION c2r
1972
1973
1978ELEMENTAL FUNCTION c2d(string) RESULT(num)
1979CHARACTER(len=*),INTENT(in) :: string
1980DOUBLE PRECISION :: num
1981
1982INTEGER :: lier
1983
1984IF (.NOT.c_e(string)) THEN
1985 num = rmiss
1986ELSE IF (len_trim(string) == 0) THEN
1987 num = rmiss
1988ELSE
1989 READ(string, '(F32.0)', iostat=lier)num
1990 IF (lier /= 0) THEN
1991 num = rmiss
1992 ENDIF
1993ENDIF
1994
1995END FUNCTION c2d
1996
1997
2003FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
2004CHARACTER(len=*), INTENT(in) :: fchar
2005INTEGER(kind=int_b) :: cstr(LEN(fchar)+1)
2006
2007cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
2008cstr(len(fchar)+1) = 0 ! zero-terminate
2009
2010END FUNCTION fchar_to_cstr
2011
2012
2018SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
2019CHARACTER(len=*), INTENT(in) :: fchar
2020INTEGER(kind=int_b), POINTER :: pcstr(:)
2021
2022ALLOCATE(pcstr(len(fchar)+1))
2023pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
2024pcstr(len(fchar)+1) = 0 ! zero-terminate
2025
2026END SUBROUTINE fchar_to_cstr_alloc
2027
2028
2032FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
2033INTEGER(kind=int_b), INTENT(in) :: cstr(:)
2034CHARACTER(len=SIZE(cstr)-1) :: fchar
2035
2036INTEGER :: i
2037
2038!l = MIN(LEN(char), SIZE(cstr)-1)
2039fchar = transfer(cstr(1:SIZE(cstr)-1), fchar)
2040DO i = 1, SIZE(cstr)-1
2041 IF (fchar(i:i) == char(0)) THEN ! truncate if the null terminator is found before
2042 fchar(i:) = ' '
2043 EXIT
2044 ENDIF
2045ENDDO
2046
2047END FUNCTION cstr_to_fchar
2048
2049
2051FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
2052CHARACTER( * ), INTENT( IN ) :: Input_String
2053CHARACTER( LEN( Input_String ) ) :: Output_String
2054 ! -- Local variables
2055INTEGER :: i, n
2056
2057 ! -- Copy input string
2058output_string = input_string
2059 ! -- Loop over string elements
2060DO i = 1, len( output_string )
2061 ! -- Find location of letter in lower case constant string
2062 n = index( lower_case, output_string( i:i ) )
2063 ! -- If current substring is a lower case letter, make it upper case
2064 IF ( n /= 0 ) output_string( i:i ) = upper_case( n:n )
2065END DO
2066END FUNCTION uppercase
2067
2068
2070FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
2071 ! -- Argument and result
2072CHARACTER( * ), INTENT( IN ) :: Input_String
2073CHARACTER( LEN( Input_String ) ) :: Output_String
2074 ! -- Local variables
2075INTEGER :: i, n
2076
2077 ! -- Copy input string
2078output_string = input_string
2079 ! -- Loop over string elements
2080DO i = 1, len( output_string )
2081 ! -- Find location of letter in upper case constant string
2082 n = index( upper_case, output_string( i:i ) )
2083 ! -- If current substring is an upper case letter, make it lower case
2084 IF ( n /= 0 ) output_string( i:i ) = lower_case( n:n )
2085END DO
2086END FUNCTION lowercase
2087
2088
2094elemental_unlessxlf FUNCTION align_center(input_string) RESULT(aligned)
2095CHARACTER(len=*), INTENT(in) :: input_string
2096
2097CHARACTER(len=LEN(input_string)) :: aligned
2098
2099INTEGER :: n1, n2
2100
2101n1 = f_nblnk(input_string)
2102n2 = len(input_string)-l_nblnk(input_string)+1
2103
2104aligned = ''
2105aligned((n1+n2)/2:) = input_string(n1:)
2106
2107END FUNCTION align_center
2108
2109
2115ELEMENTAL FUNCTION l_nblnk(input_string, blnk) RESULT(nblnk)
2116CHARACTER(len=*), INTENT(in) :: input_string
2117CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk
2118
2119CHARACTER(len=1) :: lblnk
2120INTEGER :: nblnk
2121
2122IF (PRESENT(blnk)) THEN
2123 lblnk = blnk
2124ELSE
2125 lblnk = ' '
2126ENDIF
2127
2128DO nblnk = len(input_string), 1, -1
2129 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
2130ENDDO
2131
2132END FUNCTION l_nblnk
2133
2134
2138ELEMENTAL FUNCTION f_nblnk(input_string, blnk) RESULT(nblnk)
2139CHARACTER(len=*), INTENT(in) :: input_string
2140CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk
2141
2142CHARACTER(len=1) :: lblnk
2143INTEGER :: nblnk
2144
2145IF (PRESENT(blnk)) THEN
2146 lblnk = blnk
2147ELSE
2148 lblnk = ' '
2149ENDIF
2150
2151DO nblnk = 1, len(input_string)
2152 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
2153ENDDO
2154
2155END FUNCTION f_nblnk
2156
2157
2164FUNCTION word_split(input_string, word_start, word_end, sep) RESULT(nword)
2165CHARACTER(len=*), INTENT(in) :: input_string
2166INTEGER, POINTER, OPTIONAL :: word_start(:)
2167INTEGER, POINTER, OPTIONAL :: word_end(:)
2168CHARACTER(len=1), OPTIONAL :: sep
2169
2170INTEGER :: nword
2171
2172INTEGER :: ls, le
2173INTEGER, POINTER :: lsv(:), lev(:)
2174CHARACTER(len=1) :: lsep
2175
2176IF (PRESENT(sep)) THEN
2177 lsep = sep
2178ELSE
2179 lsep = ' '
2180ENDIF
2181
2182nword = 0
2183le = 0
2184DO WHILE(.true.)
2185 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2186 IF (ls > len(input_string)) EXIT ! end of words
2187 le = index(input_string(ls:), lsep)
2188 IF (le == 0) THEN
2189 le = len(input_string)
2190 ELSE
2191 le = le + ls - 2
2192 ENDIF
2193 nword = nword + 1
2194ENDDO
2195
2196IF (.NOT.PRESENT(word_start) .AND. .NOT.PRESENT(word_end)) RETURN
2197
2198ALLOCATE(lsv(nword), lev(nword))
2199nword = 0
2200le = 0
2201DO WHILE(.true.)
2202 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2203 IF (ls > len(input_string)) EXIT ! end of words
2204 le = index(input_string(ls:), lsep)
2205 IF (le == 0) THEN
2206 le = len(input_string)
2207 ELSE
2208 le = le + ls - 2
2209 ENDIF
2210 nword = nword + 1
2211 lsv(nword) = ls
2212 lev(nword) = le
2213ENDDO
2214
2215IF (PRESENT(word_start)) THEN
2216 word_start => lsv
2217ELSE
2218 DEALLOCATE(lsv)
2219ENDIF
2220IF (PRESENT(word_end)) THEN
2221 word_end => lev
2222ELSE
2223 DEALLOCATE(lev)
2224ENDIF
2225
2226END FUNCTION word_split
2227
2228
2233FUNCTION line_split_new(line, ncols) RESULT(this)
2234CHARACTER(len=*), INTENT(in) :: line
2235INTEGER, INTENT(in), OPTIONAL :: ncols
2236
2237TYPE(line_split) :: this
2238
2239INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
2240
2241IF (PRESENT(ncols)) THEN
2242 this%ncols = ncols
2243ELSE
2244 this%ncols = default_columns()
2245ENDIF
2246! split the input line
2247nwords = word_split(line, this%word_start, this%word_end)
2248! count the lines required to accomodate the input line in a paragraph
2249nlines = 0
2250nw = 0
2251DO WHILE(nw < nwords)
2252 columns_in_line = 0
2253 words_in_line = 0
2254 DO WHILE(nw < nwords)
2255 nw = nw + 1
2256 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2257 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2258 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2259 words_in_line == 0) THEN ! accept the word
2260 columns_in_line = columns_in_line + ncols_next_word
2261 words_in_line = words_in_line + 1
2262 ELSE ! refuse the word
2263 nw = nw - 1
2264 EXIT
2265 ENDIF
2266 ENDDO
2267 nlines = nlines + 1
2268ENDDO
2269
2270!IF (nlines == 0)
2271ALLOCATE(this%paragraph(this%ncols, nlines))
2272this%paragraph = ' '
2273! repeat filling the paragraph
2274nlines = 0
2275nw = 0
2276DO WHILE(nw < nwords)
2277 columns_in_line = 0
2278 words_in_line = 0
2279 DO WHILE(nw < nwords)
2280 nw = nw + 1
2281 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2282 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2283 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2284 words_in_line == 0) THEN ! accept the word
2285 columns_in_line = columns_in_line + ncols_next_word
2286! now fill the paragraph
2287 IF (columns_in_line <= this%ncols) THEN ! non truncated line
2288 IF (words_in_line > 0) THEN ! previous space
2289 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2290 transfer(' '//line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2291 ELSE ! no previous space
2292 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2293 transfer(line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2294 ENDIF
2295 ELSE ! truncated line (word longer than line)
2296 this%paragraph(1:this%ncols,nlines+1) = &
2297 transfer(line(this%word_start(nw):this%word_start(nw)+this%ncols-1), this%paragraph)
2298 ENDIF
2299 words_in_line = words_in_line + 1
2300 ELSE ! refuse the word
2301 nw = nw - 1
2302 EXIT
2303 ENDIF
2304 ENDDO
2305 nlines = nlines + 1
2306ENDDO
2307
2308END FUNCTION line_split_new
2309
2310
2311! Cleanly destroy a \a line_split object, deallocating all the
2312! dynamically allocated space. Use the generic name \a delete rather
2313! than this specfoc subroutine.
2314SUBROUTINE line_split_delete(this)
2315TYPE(line_split), INTENT(inout) :: this ! object to be destroyed
2316
2317IF (ASSOCIATED(this%paragraph)) DEALLOCATE(this%paragraph)
2318IF (ASSOCIATED(this%word_start)) DEALLOCATE(this%word_start)
2319IF (ASSOCIATED(this%word_end)) DEALLOCATE(this%word_end)
2320
2321END SUBROUTINE line_split_delete
2322
2323
2325FUNCTION line_split_get_nlines(this) RESULT(nlines)
2326TYPE(line_split), INTENT(in) :: this
2327
2328INTEGER :: nlines
2329
2330IF (ASSOCIATED(this%paragraph)) THEN
2331 nlines = SIZE(this%paragraph, 2)
2332ELSE
2333 nlines = 0
2334ENDIF
2335
2336END FUNCTION line_split_get_nlines
2337
2338
2343FUNCTION line_split_get_line(this, nline) RESULT(line)
2344TYPE(line_split), INTENT(in) :: this
2345INTEGER, INTENT(in) :: nline
2346
2347CHARACTER(len=SIZE(this%paragraph, 1)) :: line
2348IF (nline > 0 .AND. nline <= SIZE(this%paragraph, 2)) THEN
2349 line = transfer(this%paragraph(:,nline), line)
2350ELSE
2351 line = cmiss
2352ENDIF
2353
2354END FUNCTION line_split_get_line
2355
2356
2362FUNCTION default_columns() RESULT(cols)
2363INTEGER :: cols
2364
2365INTEGER, PARAMETER :: defaultcols = 80 ! default of the defaults
2366INTEGER, PARAMETER :: maxcols = 256 ! maximum value
2367CHARACTER(len=10) :: ccols
2368
2369cols = defaultcols
2370CALL getenv('COLUMNS', ccols)
2371IF (ccols == '') RETURN
2372
2373READ(ccols, '(I10)', err=100) cols
2374cols = min(cols, maxcols)
2375IF (cols <= 0) cols = defaultcols
2376RETURN
2377
2378100 cols = defaultcols ! error in reading the value
2379
2380END FUNCTION default_columns
2381
2382
2384FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
2385! -- Argument and result
2386CHARACTER( * ), INTENT( IN ) :: Input_String
2387CHARACTER( LEN( Input_String ) ) :: Output_String
2388! -- Local variables
2389INTEGER :: i
2390
2391output_string=""
2392i = index(input_string,".",back=.true.)
2393if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
2394
2395END FUNCTION suffixname
2396
2397
2404elemental_unlessxlf FUNCTION wash_char(in, goodchar, badchar) RESULT(char)
2405CHARACTER(len=*),INTENT(in) :: in
2406CHARACTER(len=*),INTENT(in),OPTIONAL :: badchar
2407CHARACTER(len=*),INTENT(in),OPTIONAL :: goodchar
2408integer,allocatable :: igoodchar(:)
2409integer,allocatable :: ibadchar(:)
2410
2411CHARACTER(len=len(in)) :: char,charr,charrr
2412INTEGER :: i,ia,nchar
2413
2414char=""
2415charr=""
2416charrr=""
2417
2418if (present(goodchar)) then
2419
2420allocate(igoodchar(len(goodchar)))
2421
2422 do i =1, len(goodchar)
2423 igoodchar=ichar(goodchar(i:i))
2424 end do
2425
2426 nchar=0
2427 do i=1,len(in)
2428 ia = ichar(in(i:i))
2429 if (any(ia == igoodchar))then
2430 nchar=nchar+1
2431 charrr(nchar:nchar)=achar(ia)
2432 end if
2433 end do
2434
2435deallocate(igoodchar)
2436
2437else
2438
2439 charrr=in
2440
2441end if
2442
2443
2444
2445if (present(badchar)) then
2446
2447allocate(ibadchar(len(badchar)))
2448
2449 do i =1, len(badchar)
2450 ibadchar=ichar(badchar(i:i))
2451 end do
2452
2453 nchar=0
2454 do i=1,len(charrr)
2455 ia = ichar(charrr(i:i))
2456 if (.not. any(ia == ibadchar))then
2457 nchar=nchar+1
2458 charr(nchar:nchar)=achar(ia)
2459 end if
2460 end do
2461
2462deallocate(ibadchar)
2463
2464else
2465
2466 charr=charrr
2467
2468end if
2469
2470
2471if (.not. present(goodchar) .and. .not. present(badchar)) then
2472
2473 nchar=0
2474 do i=1,len(charr)
2475 ia = ichar(charr(i:i))
2476 if ((ia >= 65 .and. ia <= 90) .or. &
2477 (ia >= 97 .and. ia <= 122))then
2478 nchar=nchar+1
2479 char(nchar:nchar)=achar(ia)
2480 end if
2481 end do
2482
2483else
2484
2485 char=charr
2486
2487end if
2488
2489
2490END FUNCTION wash_char
2491
2492
2493! derived by http://sourceforge.net/projects/flibs
2494!
2495! globmatch.f90 --
2496! Match strings according to (simplified) glob patterns
2497!
2498! The pattern matching is limited to literals, * and ?
2499! (character classes are not supported). A backslash escapes
2500! any character.
2501!
2502! $Id: globmatch.f90,v 1.5 2006/03/26 19:03:53 arjenmarkus Exp $
2503!!$Copyright (c) 2008, Arjen Markus
2504!!$
2505!!$All rights reserved.
2506!!$
2507!!$Redistribution and use in source and binary forms, with or without modification,
2508!!$are permitted provided that the following conditions are met:
2509!!$
2510!!$Redistributions of source code must retain the above copyright notice,
2511!!$this list of conditions and the following disclaimer.
2512!!$Redistributions in binary form must reproduce the above copyright notice,
2513!!$this list of conditions and the following disclaimer in the documentation
2514!!$and/or other materials provided with the distribution.
2515!!$Neither the name of the author nor the names of the contributors
2516!!$may be used to endorse or promote products derived from this software
2517!!$without specific prior written permission.
2518!!$THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2519!!$"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
2520!!$THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
2521!!$ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
2522!!$FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
2523!!$DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
2524!!$SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2525!!$CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
2526!!$OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
2527!!$OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2528!
2529
2533function string_match_v( string, pattern ) result(match)
2534character(len=*), intent(in) :: string(:)
2535character(len=*), intent(in) :: pattern
2536logical :: match(size(string))
2537
2538integer :: i
2539
2540do i =1,size(string)
2541 match(i)=string_match(string(i),pattern)
2542end do
2543
2544end function string_match_v
2545
2546
2550recursive function string_match( string, pattern ) result(match)
2551 character(len=*), intent(in) :: string
2552 character(len=*), intent(in) :: pattern
2553 logical :: match
2554
2555! '\\' without -fbackslash generates a warning on gfortran, '\'
2556! crashes doxygen, so we choose '\\' and -fbackslash in configure.ac
2557 character(len=1), parameter :: backslash = '\\'
2558 character(len=1), parameter :: star = '*'
2559 character(len=1), parameter :: question = '?'
2560
2561 character(len=len(pattern)) :: literal
2562 integer :: ptrim
2563 integer :: p
2564 integer :: k
2565 integer :: ll
2566 integer :: method
2567 integer :: start
2568 integer :: strim
2569
2570 match = .false.
2571 method = 0
2572 ptrim = len_trim( pattern )
2573 strim = len_trim( string )
2574 p = 1
2575 ll = 0
2576 start = 1
2577
2578 !
2579 ! Split off a piece of the pattern
2580 !
2581 do while ( p <= ptrim )
2582 select case ( pattern(p:p) )
2583 case( star )
2584 if ( ll .ne. 0 ) exit
2585 method = 1
2586 case( question )
2587 if ( ll .ne. 0 ) exit
2588 method = 2
2589 start = start + 1
2590 case( backslash )
2591 p = p + 1
2592 ll = ll + 1
2593 literal(ll:ll) = pattern(p:p)
2594 case default
2595 ll = ll + 1
2596 literal(ll:ll) = pattern(p:p)
2597 end select
2598
2599 p = p + 1
2600 enddo
2601
2602 !
2603 ! Now look for the literal string (if any!)
2604 !
2605 if ( method == 0 ) then
2606 !
2607 ! We are at the end of the pattern, and of the string?
2608 !
2609 if ( strim == 0 .and. ptrim == 0 ) then
2610 match = .true.
2611 else
2612 !
2613 ! The string matches a literal part?
2614 !
2615 if ( ll > 0 ) then
2616 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2617 start = start + ll
2618 match = string_match( string(start:), pattern(p:) )
2619 endif
2620 endif
2621 endif
2622 endif
2623
2624 if ( method == 1 ) then
2625 !
2626 ! Scan the whole of the remaining string ...
2627 !
2628 if ( ll == 0 ) then
2629 match = .true.
2630 else
2631 do while ( start <= strim )
2632 k = index( string(start:), literal(1:ll) )
2633 if ( k > 0 ) then
2634 start = start + k + ll - 1
2635 match = string_match( string(start:), pattern(p:) )
2636 if ( match ) then
2637 exit
2638 endif
2639 endif
2640
2641 start = start + 1
2642 enddo
2643 endif
2644 endif
2645
2646 if ( method == 2 .and. ll > 0 ) then
2647 !
2648 ! Scan the whole of the remaining string ...
2649 !
2650 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2651 match = string_match( string(start+ll:), pattern(p:) )
2652 endif
2653 endif
2654 return
2655end function string_match
2656
2657
2658SUBROUTINE print_status_line(line)
2659CHARACTER(len=*),INTENT(in) :: line
2660CHARACTER(len=1),PARAMETER :: cr=char(13)
2661WRITE(stdout_unit,'(2A)',advance='no')cr,trim(line)
2662FLUSH(unit=6) ! probably useless with gfortran, required with Intel fortran
2663END SUBROUTINE print_status_line
2664
2665SUBROUTINE done_status_line()
2666WRITE(stdout_unit,'()')
2667END SUBROUTINE done_status_line
2668
2669
2678SUBROUTINE progress_line_update_d(this, val)
2679CLASS(progress_line),INTENT(inout) :: this
2680DOUBLE PRECISION,INTENT(in) :: val
2681
2682INTEGER :: vint, i
2683CHARACTER(len=512) :: line
2684
2685IF (this%curr >= this%max) RETURN ! line is already closed, do nothing
2686
2687this%curr = max(this%min, min(this%max, val))
2688this%spin = mod(this%spin+1, 4)
2689line = ''
2690
2691vint = nint((this%curr-this%min)/(this%max-this%min)*100.d0)
2692WRITE(line,this%form)vint, &
2693 progress_line_spin(this%spin+1:this%spin+1)
2694vint = vint/10
2695
2696DO i = 1, vint
2697 line(this%barloc+i:this%barloc+i) = this%done
2698ENDDO
2699DO i = vint+1, 10
2700 line(this%barloc+i:this%barloc+i) = this%todo
2701ENDDO
2702CALL print_status_line(line)
2703IF (this%curr >= this%max) CALL done_status_line()
2704
2705END SUBROUTINE progress_line_update_d
2706
2707
2712SUBROUTINE progress_line_update_i(this, val)
2713CLASS(progress_line),INTENT(inout) :: this
2714INTEGER,INTENT(in) :: val
2715
2716CALL progress_line_update_d(this, dble(val))
2717
2718END SUBROUTINE progress_line_update_i
2719
2725SUBROUTINE progress_line_alldone(this)
2726CLASS(progress_line),INTENT(inout) :: this
2727CALL progress_line_update_d(this, this%max)
2728END SUBROUTINE progress_line_alldone
2729
2730
2731END 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.