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