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