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