libsim Versione 7.2.6

◆ progress_line_update_i()

subroutine progress_line_update_i ( class(progress_line), intent(inout) this,
integer, intent(in) val )
private

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.

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

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/>.
1482!> \brief Utilities for CHARACTER variables.
1483!!
1484!! This module is a collection of all-purpose utilities connected to
1485!! the use of CHARACTER variables, and text handling in general.
1486!!
1487!! \ingroup base
1488#include "config.h"
1489MODULE char_utilities
1490USE kinds
1492USE io_units
1493IMPLICIT NONE
1494
1495CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
1496CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1497
1498!> Set of functions that return a CHARACTER representation of the
1499!! input variable. The return value is of type \a CHARACTER with a
1500!! predefined length depending on the type of the input. The functions
1501!! use a default format suitable to reasonably represent the input
1502!! variable, or a user-defined format provided with the optional
1503!! variable \a form. The \a miss optional value, if provided,
1504!! replaces the output representation in case the input is missing
1505!! according to the definitions in \a missing_values module. The
1506!! length of the \a miss parameter should not exceed the length of the
1507!! maximum representable value of the provided type, otherwise it may
1508!! be truncated. For numerical types, the return value may be quite
1509!! long, in order to take into account all possible cases, so it is
1510!! suggested to trim the result with the intrinsic function \a TRIM()
1511!! before using it. Be warned that no check is performed on the
1512!! optional format \a form, so a runtime error may occur if it is
1513!! syntactically wrong or not suitable to the data type provided. The
1514!! functions are \a ELEMENTAL, so they can be applied to arrays of any
1515!! shape.
1516!!
1517!! \param in (any type of INTEGER, REAL or CHARACTER) value to be represented as CHARACTER
1518!! \param miss CHARACTER(len=*),INTENT(in),OPTIONAL optional character replacement for missing value
1519!! \param form CHARACTER(len=*),INTENT(in),OPTIONAL optional format
1520!!
1521!! Example of use:
1522!! \code
1523!! USE char_utilities
1524!! INTEGER :: j
1525!! ...
1526!! WRITE(*,*)'The value provided, '//TRIM(to_char(j))//', is too large'
1527!! ...
1528!! \endcode
1529INTERFACE to_char
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
1536!> Set of functions that return a trimmed CHARACTER representation of the
1537!! input variable. The functions are analogous to \a to_char but they
1538!! return a representation of the input in a CHARACTER with a variable
1539!! length, which needs not to be trimmed before use. The optional
1540!! format here is not accepted and these functions are not \a
1541!! ELEMENTAL so they work only on scalar arguments.
1542!!
1543!! \param in (any type of INTEGER, REAL or CHARACTER) value to be represented as CHARACTER
1544!! \param miss CHARACTER(len=*),INTENT(in),OPTIONAL optional character replacement for missing value
1545!!
1546!! Example of use:
1547!! \code
1548!! USE char_utilities
1549!! INTEGER :: j
1550!! ...
1551!! WRITE(*,*)'The value provided, '//t2c(j)//', is too large'
1552!! ...
1553!! \endcode
1554INTERFACE t2c
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
1563!> Class that allows splitting a long line into shorter lines of equal
1564!! length at the occurrence of a specific character (typically a blank
1565!! space). All the members of the class are \a PRIVATE, thus all the
1566!! operations are performed through its methods.
1567TYPE line_split
1568 PRIVATE
1569 INTEGER :: align_type, ncols, nlines
1570 INTEGER, POINTER :: word_start(:), word_end(:)
1571 CHARACTER(len=1), POINTER :: paragraph(:,:)
1572END TYPE line_split
1573
1574!> Destructor for the \a line_split class.
1575!! It cleanly destroys a \a line_split object, deallocating all the
1576!! dynamically allocated space.
1577!!
1578!! \param this (TYPE(line_split)) object to be destroyed
1579INTERFACE delete
1580 MODULE PROCEDURE line_split_delete
1581END INTERFACE
1582
1583
1584!> Tries to match the given string with the pattern
1585!! Result:
1586!! .true. if the entire string matches the pattern, .false.
1587!! otherwise
1588!! Note:
1589!! Trailing blanks are ignored
1590!!
1591!! provides a string matching method known as glob matching: it is used
1592!! for instance under UNIX, Linux and DOS to select files whose names
1593!! match a certain pattern - strings like "*.f90" describe all file
1594!! swhose names end in ".f90".
1595!!
1596!! The method implemented in the module is somewhat simplified than the
1597!! full glob matching possible under UNIX: it does not support
1598!! character classes.
1599!!
1600!! Glob patterns are intended to match the entire string. In this
1601!! implementation, however, trailing blanks in both the string and the
1602!! pattern are ignored, so that it is a bit easier to use in Fortran.
1603!!
1604!! The module supports both "*" and "?" as wild cards, where "*" means
1605!! any sequence of characters, including zero and "?" means a single
1606!! character. If you need to match the characters "*" or "?", then
1607!! precede them with a backslash ("\"). If you need to match a
1608!! backslash, you will need to use two:
1609!!
1610!!
1611!! match = string_match( "c:\somedir" "c:\\*" )
1612!!
1613!! will return .true., while:
1614!!
1615!! match = string_match( "c:\somedir" "c:\*" )
1616!!
1617!! will not match, as the backslash "escapes" the asterisk, which then becomes an ordinary character.
1618!!
1619!! BUGS
1620!!
1621!! The matching algorithm is not flawless:
1622!!
1623!! * Patterns like "e* *" may fail, because trailing blanks are
1624!! removed. The string "e " ought to match this pattern, but
1625!! because only the substring "e" will be considered, the
1626!! trailing blank that is necessary for matching between the two
1627!! asterisks is removed from the matching process.
1628!!
1629!! The test program contains a case that should fail on this, but it does not, oddly enough.
1630!!
1631!! * Patterns like "b*ba" fail on a string like "babababa" because
1632!! the algorithm finds an early match (the substring at 3:4) for
1633!! the last literal substring "ba" in the pattern. It should
1634!! instead skip over that substring and search for the substring
1635!! 7:8.
1636!!
1637!! There are two ways to deal with this:
1638!!
1639!! o Insert an extra character at the end, which does not occur anywhere in the pattern.
1640!!
1641!! o If the match fails, continue at a point after the position of the literal substring where matching failed.
1642!!
1643!! The second is probably the way to go, but it may be a bit slower.
1644INTERFACE match
1645 MODULE PROCEDURE string_match, string_match_v
1646END INTERFACE
1647
1648
1649!> Class to print a progress bar on the screen.
1650!! This class prints a progress bar on the screen, which can be
1651!! updated by the calling program. At the moment the progress can only
1652!! be displayed in percent (0-100) of the min-max progress interval,
1653!! with a predefined format. The progress interval also defaults to
1654!! 0-100 but it can be changed by the user after instantiating the
1655!! object, but before updating it.
1656TYPE progress_line
1657 DOUBLE PRECISION :: min=0.0d0 !< minimum value of the progress interval
1658 DOUBLE PRECISION :: max=100.0d0 !< minimum value of the progress interval
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
1668END TYPE progress_line
1669
1670CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
1671
1672PRIVATE
1673PUBLIC line_split
1674PUBLIC to_char, t2c, c2i, c2r, c2d, delete, match, &
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
1692 IF (.NOT.c_e(in)) 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
1740 IF (.NOT.c_e(in)) 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
1796IF (c_e(in)) THEN
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
1835 IF (.NOT.c_e(in)) 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
1887 IF (.NOT.c_e(in)) 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
1954!> Convert a character string to an integer value if possible.
1955!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
1956!! missing value if the input cannot be converted or is empty or
1957!! missing.
1958ELEMENTAL FUNCTION c2i(string) RESULT(num)
1959CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a INTEGER
1960INTEGER :: num
1961
1962INTEGER :: lier
1963
1964IF (.NOT.c_e(string)) THEN
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
1978!> Convert a character string to a real value if possible.
1979!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
1980!! missing value if the input cannot be converted or is empty or
1981!! missing.
1982ELEMENTAL FUNCTION c2r(string) RESULT(num)
1983CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a REAL
1984REAL :: num
1985
1986INTEGER :: lier
1987
1988IF (.NOT.c_e(string)) THEN
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
2002!> Convert a character string to a double value if possible.
2003!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
2004!! missing value if the input cannot be converted or is empty or
2005!! missing.
2006ELEMENTAL FUNCTION c2d(string) RESULT(num)
2007CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a DOUBLE \a PRECISION
2008DOUBLE PRECISION :: num
2009
2010INTEGER :: lier
2011
2012IF (.NOT.c_e(string)) THEN
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
2026!> Converts a \a CHARACTER variable into a string which can be
2027!! directly passed to a C function requiring a null-terminated \a
2028!! const \a char* (input) argument. If the result is going to be
2029!! stored into an array, this has to be dimensioned with a suitable
2030!! size (\a LEN(fchar) \a + \a 1 ).
2031FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
2032CHARACTER(len=*), INTENT(in) :: fchar !< variable to be converted
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
2041!> Converts a \a CHARACTER variable into a string which can be
2042!! directly passed to a C function requiring a null-terminated \a
2043!! char* (input/output) argument. The result is stored into \a pcstr
2044!! which is allocated within the subroutine and has to be deallocated
2045!! by the calling procedure.
2046SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
2047CHARACTER(len=*), INTENT(in) :: fchar !< variable to be converted
2048INTEGER(kind=int_b), POINTER :: pcstr(:) !< pointer to a 1-d byte array which will be allocated and, on output, will contain the null-terminated string
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
2057!> Converts a null-terminated C-style string into a Fortran \a CHARACTER
2058!! variable of the same length, the null termination character is
2059!! removed.
2060FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
2061INTEGER(kind=int_b), INTENT(in) :: cstr(:) !< variable to be converted
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
2078!> Convert a \a CHARACTER variable to uppercase.
2079FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
2080CHARACTER( * ), INTENT( IN ) :: Input_String !< variable to be converted
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
2097!> Convert a \a CHARACTER variable to lowercase.
2098FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
2099 ! -- Argument and result
2100CHARACTER( * ), INTENT( IN ) :: Input_String !< variable to be converted
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
2117!> Returns \a input_string centered, i.e.\ with an equal number of
2118!! leading and trailing blanks (±1 if they are odd). The needed
2119!! number of leading/trailing blanks is added or removed at the
2120!! beginning and/or at the end in order to keep the length of the
2121!! resulting string equal to the input length.
2122ELEMENTAL FUNCTION align_center(input_string) RESULT(aligned)
2123CHARACTER(len=*), INTENT(in) :: input_string !< string to be aligned
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
2138!> Return the index of last character in \a input_string which is not
2139!! a blank space. If the string is zero-length or contains only blank
2140!! spaces, zero is returned. It is named l_nblnk and not lnblnk in
2141!! order to avoid conflict with a nondefault intrinsic Fortran
2142!! function with the same name, available on some compilers.
2143ELEMENTAL FUNCTION l_nblnk(input_string, blnk) RESULT(nblnk)
2144CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2145CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk !< optional blank character, if not provided, a blank space is assumed
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
2163!> Return the index of first character in \a input_string which is not
2164!! a blank space. If the string is zero-length or contains only blank
2165!! spaces, \a LEN(input_string)+1 is returned.
2166ELEMENTAL FUNCTION f_nblnk(input_string, blnk) RESULT(nblnk)
2167CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2168CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk !< optional blank character, if not provided, a blank space is assumed
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
2186!> Split a line into words at a predefined character (default blank).
2187!! Returns the number of words in \a input_string. If pointers \a
2188!! word_start and \a word_end are provided, they are allocated with \a
2189!! nword elements and set to the indices of initial and final
2190!! character of every word in \a input_string. Groups of contiguous
2191!! separation characters are treated as a single separator character.
2192FUNCTION word_split(input_string, word_start, word_end, sep) RESULT(nword)
2193CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2194INTEGER, POINTER, OPTIONAL :: word_start(:) !< indices of first character of each word in \a input_string, allocated here, must be deallocated by the user
2195INTEGER, POINTER, OPTIONAL :: word_end(:) !< indices of last character of each word in \a input_string, allocated here, must be deallocated by the user
2196CHARACTER(len=1), OPTIONAL :: sep !< optional word separator character, if not provided, a blank space is assumed
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
2257!> Constructor for the \a line_split class. It creates a new object
2258!! allowing to split a line of text into multiple lines of predefined
2259!! length at blank spaces. If a line can't be splitted because a word
2260!! is longer than the line, it is truncated.
2261FUNCTION line_split_new(line, ncols) RESULT(this)
2262CHARACTER(len=*), INTENT(in) :: line !< line to be splitted
2263INTEGER, INTENT(in), OPTIONAL :: ncols !< maximum number of columns on every line, if not provided a suitable default is used
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
2352!> Return the number of lines over which the input line was splitted.
2353FUNCTION line_split_get_nlines(this) RESULT(nlines)
2354TYPE(line_split), INTENT(in) :: this !< object initialised with the line to be splitted
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
2367!> Return the \a nline-th line obtained after splitting. If \a nline
2368!! is out of range, a missing value is returned. The line is always
2369!! left-aligned and it is padded with trailing blanks up to the
2370!! requested line length.
2371FUNCTION line_split_get_line(this, nline) RESULT(line)
2372TYPE(line_split), INTENT(in) :: this !< object initialised with the line to be splitted
2373INTEGER, INTENT(in) :: nline !< index of the line to be returned
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
2385!> Return the number of columns in the terminal, if available it is
2386!! taken from the \a COLUMNS environment variable (it may be necessary
2387!! to execute \c export \c COLUMNS before running the program, in
2388!! order for this to work), otherwise it is set to 80. A positive
2389!! value is returned in any case
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
2411!> Return the suffix of a filename.
2412FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
2413! -- Argument and result
2414CHARACTER( * ), INTENT( IN ) :: Input_String !< string to be interpreted as a filename
2415CHARACTER( LEN( Input_String ) ) :: Output_String
2416! -- Local variables
2417INTEGER :: i
2418
2419output_string=""
2420i = index(input_string,".",back=.true.)
2421if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
2422
2423END FUNCTION suffixname
2424
2425
2426!> Remove the requested characters from a string.
2427!! This function returns a string cleaned from unwanted characters,
2428!! either by removing "bad" characters (argument \a badchar) or by
2429!! keeping only "good" characters (argument \a goodchar). If neither
2430!! \a badchar nor \a goodchar are provided, it keeps only alphabetic
2431!! ASCII characters.
2432ELEMENTAL FUNCTION wash_char(in, goodchar, badchar) RESULT(char)
2433CHARACTER(len=*),INTENT(in) :: in !< string to be cleaned
2434CHARACTER(len=*),INTENT(in),OPTIONAL :: badchar !< optional set of "bad" characters
2435CHARACTER(len=*),INTENT(in),OPTIONAL :: goodchar !< optional set of "good" characters
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
2558!> Tries to match the given string with the pattern (array version).
2559!! Returns \a .TRUE. if the entire string matches the pattern, \a
2560!! .FALSE. otherwise. Note: trailing blanks are ignored.
2561function string_match_v( string, pattern ) result(match)
2562character(len=*), intent(in) :: string(:) !< string to be examined
2563character(len=*), intent(in) :: pattern !< glob pattern to be used for the matching
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
2575!> Tries to match the given string with the pattern.
2576!! Returns \a .TRUE. if the entire string matches the pattern, \a
2577!! .FALSE. otherwise. Note: trailing blanks are ignored.
2578recursive function string_match( string, pattern ) result(match)
2579 character(len=*), intent(in) :: string !< String to be examined
2580 character(len=*), intent(in) :: pattern !< Glob pattern to be used for the matching
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:) )
2664 if ( match ) then
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
2698!> Update a progress line with a new value.
2699!! This subroutine updates the progress line object with a new double
2700!! precision value \a val. Values outside the range \a this%min, \a
2701!! this%max are truncated. If \a val is equal or greter maximum the
2702!! progress bar is closed so that a new line can be printed. When a
2703!! progress_line object reaches its maximum it can no more be updated
2704!! and/or closed. Use the interface method \a update rather than this
2705!! subroutine directly.
2706SUBROUTINE progress_line_update_d(this, val)
2707CLASS(progress_line),INTENT(inout) :: this !< progress_line object to be updated
2708DOUBLE PRECISION,INTENT(in) :: val !< new value
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
2736!> Update a progress line with a new value.
2737!! This subroutine is equivalent to \a progress_line_update_d but it
2738!! accepts an inteer value \a val. Use the interface method \a update
2739!! rather than this subroutine directly.
2740SUBROUTINE progress_line_update_i(this, val)
2741CLASS(progress_line),INTENT(inout) :: this !< progress_line object to be updated
2742INTEGER,INTENT(in) :: val !< new value
2743
2744CALL progress_line_update_d(this, dble(val))
2745
2746END SUBROUTINE progress_line_update_i
2747
2748!> Close artificially the progress_line object.
2749!! This subroutine forces the progress_line object to be closed
2750!! regardless of the value reached by the progress counter. It does
2751!! not need to be called if the \a update method has already been
2752!! called with the maximum progress value.
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
2759END MODULE char_utilities
Destructor for the line_split class.
Tries to match the given string with the pattern Result: .true.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Index method.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition kinds.F90:245
Definitions of constants and functions for working with missing values.
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Class to print a progress bar on the screen.

Generated with Doxygen.