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