libsim Versione 7.2.6

◆ progress_line_update_d()

subroutine progress_line_update_d ( class(progress_line), intent(inout) this,
double precision, intent(in) val )
private

Update a progress line with a new value.

This subroutine updates the progress line object with a new double precision value val. Values outside the range thismin, thismax are truncated. If val is equal or greter maximum the progress bar is closed so that a new line can be printed. When a progress_line object reaches its maximum it can no more be updated and/or closed. 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 1430 del file char_utilities.F90.

1431! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1432! authors:
1433! Davide Cesari <dcesari@arpa.emr.it>
1434! Paolo Patruno <ppatruno@arpa.emr.it>
1435
1436! This program is free software; you can redistribute it and/or
1437! modify it under the terms of the GNU General Public License as
1438! published by the Free Software Foundation; either version 2 of
1439! the License, or (at your option) any later version.
1440
1441! This program is distributed in the hope that it will be useful,
1442! but WITHOUT ANY WARRANTY; without even the implied warranty of
1443! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1444! GNU General Public License for more details.
1445
1446! You should have received a copy of the GNU General Public License
1447! along with this program. If not, see <http://www.gnu.org/licenses/>.
1448!> \brief Utilities for CHARACTER variables.
1449!!
1450!! This module is a collection of all-purpose utilities connected to
1451!! the use of CHARACTER variables, and text handling in general.
1452!!
1453!! \ingroup base
1454#include "config.h"
1455MODULE char_utilities
1456USE kinds
1458USE io_units
1459IMPLICIT NONE
1460
1461CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
1462CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
1463
1464!> Set of functions that return a CHARACTER representation of the
1465!! input variable. The return value is of type \a CHARACTER with a
1466!! predefined length depending on the type of the input. The functions
1467!! use a default format suitable to reasonably represent the input
1468!! variable, or a user-defined format provided with the optional
1469!! variable \a form. The \a miss optional value, if provided,
1470!! replaces the output representation in case the input is missing
1471!! according to the definitions in \a missing_values module. The
1472!! length of the \a miss parameter should not exceed the length of the
1473!! maximum representable value of the provided type, otherwise it may
1474!! be truncated. For numerical types, the return value may be quite
1475!! long, in order to take into account all possible cases, so it is
1476!! suggested to trim the result with the intrinsic function \a TRIM()
1477!! before using it. Be warned that no check is performed on the
1478!! optional format \a form, so a runtime error may occur if it is
1479!! syntactically wrong or not suitable to the data type provided. The
1480!! functions are \a ELEMENTAL, so they can be applied to arrays of any
1481!! shape.
1482!!
1483!! \param in (any type of INTEGER, REAL or CHARACTER) value to be represented as CHARACTER
1484!! \param miss CHARACTER(len=*),INTENT(in),OPTIONAL optional character replacement for missing value
1485!! \param form CHARACTER(len=*),INTENT(in),OPTIONAL optional format
1486!!
1487!! Example of use:
1488!! \code
1489!! USE char_utilities
1490!! INTEGER :: j
1491!! ...
1492!! WRITE(*,*)'The value provided, '//TRIM(to_char(j))//', is too large'
1493!! ...
1494!! \endcode
1495INTERFACE to_char
1496 MODULE PROCEDURE int_to_char, byte_to_char, &
1497 real_to_char, double_to_char, logical_to_char, &
1498 char_to_char, char_to_char_miss
1499END INTERFACE
1500
1501
1502!> Set of functions that return a trimmed CHARACTER representation of the
1503!! input variable. The functions are analogous to \a to_char but they
1504!! return a representation of the input in a CHARACTER with a variable
1505!! length, which needs not to be trimmed before use. The optional
1506!! format here is not accepted and these functions are not \a
1507!! ELEMENTAL so they work only on scalar arguments.
1508!!
1509!! \param in (any type of INTEGER, REAL or CHARACTER) value to be represented as CHARACTER
1510!! \param miss CHARACTER(len=*),INTENT(in),OPTIONAL optional character replacement for missing value
1511!!
1512!! Example of use:
1513!! \code
1514!! USE char_utilities
1515!! INTEGER :: j
1516!! ...
1517!! WRITE(*,*)'The value provided, '//t2c(j)//', is too large'
1518!! ...
1519!! \endcode
1520INTERFACE t2c
1521 MODULE PROCEDURE trim_int_to_char, trim_int_to_char_miss, &
1522 trim_byte_to_char, trim_byte_to_char_miss, &
1523 trim_real_to_char, trim_real_to_char_miss, &
1524 trim_double_to_char, trim_double_to_char_miss, trim_logical_to_char, &
1525 trim_char_to_char, trim_char_to_char_miss
1526END INTERFACE
1527
1528
1529!> Class that allows splitting a long line into shorter lines of equal
1530!! length at the occurrence of a specific character (typically a blank
1531!! space). All the members of the class are \a PRIVATE, thus all the
1532!! operations are performed through its methods.
1533TYPE line_split
1534 PRIVATE
1535 INTEGER :: align_type, ncols, nlines
1536 INTEGER, POINTER :: word_start(:), word_end(:)
1537 CHARACTER(len=1), POINTER :: paragraph(:,:)
1538END TYPE line_split
1539
1540!> Destructor for the \a line_split class.
1541!! It cleanly destroys a \a line_split object, deallocating all the
1542!! dynamically allocated space.
1543!!
1544!! \param this (TYPE(line_split)) object to be destroyed
1545INTERFACE delete
1546 MODULE PROCEDURE line_split_delete
1547END INTERFACE
1548
1549
1550!> Tries to match the given string with the pattern
1551!! Result:
1552!! .true. if the entire string matches the pattern, .false.
1553!! otherwise
1554!! Note:
1555!! Trailing blanks are ignored
1556!!
1557!! provides a string matching method known as glob matching: it is used
1558!! for instance under UNIX, Linux and DOS to select files whose names
1559!! match a certain pattern - strings like "*.f90" describe all file
1560!! swhose names end in ".f90".
1561!!
1562!! The method implemented in the module is somewhat simplified than the
1563!! full glob matching possible under UNIX: it does not support
1564!! character classes.
1565!!
1566!! Glob patterns are intended to match the entire string. In this
1567!! implementation, however, trailing blanks in both the string and the
1568!! pattern are ignored, so that it is a bit easier to use in Fortran.
1569!!
1570!! The module supports both "*" and "?" as wild cards, where "*" means
1571!! any sequence of characters, including zero and "?" means a single
1572!! character. If you need to match the characters "*" or "?", then
1573!! precede them with a backslash ("\"). If you need to match a
1574!! backslash, you will need to use two:
1575!!
1576!!
1577!! match = string_match( "c:\somedir" "c:\\*" )
1578!!
1579!! will return .true., while:
1580!!
1581!! match = string_match( "c:\somedir" "c:\*" )
1582!!
1583!! will not match, as the backslash "escapes" the asterisk, which then becomes an ordinary character.
1584!!
1585!! BUGS
1586!!
1587!! The matching algorithm is not flawless:
1588!!
1589!! * Patterns like "e* *" may fail, because trailing blanks are
1590!! removed. The string "e " ought to match this pattern, but
1591!! because only the substring "e" will be considered, the
1592!! trailing blank that is necessary for matching between the two
1593!! asterisks is removed from the matching process.
1594!!
1595!! The test program contains a case that should fail on this, but it does not, oddly enough.
1596!!
1597!! * Patterns like "b*ba" fail on a string like "babababa" because
1598!! the algorithm finds an early match (the substring at 3:4) for
1599!! the last literal substring "ba" in the pattern. It should
1600!! instead skip over that substring and search for the substring
1601!! 7:8.
1602!!
1603!! There are two ways to deal with this:
1604!!
1605!! o Insert an extra character at the end, which does not occur anywhere in the pattern.
1606!!
1607!! o If the match fails, continue at a point after the position of the literal substring where matching failed.
1608!!
1609!! The second is probably the way to go, but it may be a bit slower.
1610INTERFACE match
1611 MODULE PROCEDURE string_match, string_match_v
1612END INTERFACE
1613
1614
1615!> Class to print a progress bar on the screen.
1616!! This class prints a progress bar on the screen, which can be
1617!! updated by the calling program. At the moment the progress can only
1618!! be displayed in percent (0-100) of the min-max progress interval,
1619!! with a predefined format. The progress interval also defaults to
1620!! 0-100 but it can be changed by the user after instantiating the
1621!! object, but before updating it.
1622TYPE progress_line
1623 DOUBLE PRECISION :: min=0.0d0 !< minimum value of the progress interval
1624 DOUBLE PRECISION :: max=100.0d0 !< minimum value of the progress interval
1625 DOUBLE PRECISION,PRIVATE :: curr=0.0d0
1626 CHARACTER(len=512),PRIVATE :: form='(''|'',I3.0,''%|'',A,''|'',10X,''|'')'
1627 CHARACTER(len=1),PRIVATE :: done='='
1628 CHARACTER(len=1),PRIVATE :: todo='-'
1629 INTEGER,PRIVATE :: barloc=8
1630 INTEGER,PRIVATE :: spin=0
1631 CONTAINS
1632 PROCEDURE :: update => progress_line_update_d, progress_line_update_i
1633 PROCEDURE :: alldone => progress_line_alldone
1634END TYPE progress_line
1635
1636CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
1637
1638PRIVATE
1639PUBLIC line_split
1640PUBLIC to_char, t2c, c2i, c2r, c2d, delete, match, &
1641 fchar_to_cstr, fchar_to_cstr_alloc, cstr_to_fchar, uppercase, lowercase, &
1642 align_center, l_nblnk, f_nblnk, word_split, &
1643 line_split_new, line_split_get_nlines, line_split_get_line, &
1644 suffixname, default_columns, wash_char, &
1645 print_status_line, done_status_line, progress_line
1646
1647CONTAINS
1648
1649! Version with integer argument, please use the generic \a to_char
1650! rather than this function directly.
1651ELEMENTAL FUNCTION int_to_char(in, miss, form) RESULT(char)
1652INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1653CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1654CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1655CHARACTER(len=11) :: char
1656
1657IF (PRESENT(miss)) THEN
1658 IF (.NOT.c_e(in)) THEN
1659 char = miss
1660 ELSE
1661 IF (PRESENT(form)) THEN
1662 WRITE(char,form)in
1663 ELSE
1664 WRITE(char,'(I0)')in
1665 ENDIF
1666 ENDIF
1667ELSE
1668 IF (PRESENT(form)) THEN
1669 WRITE(char,form)in
1670 ELSE
1671 WRITE(char,'(I0)')in
1672 ENDIF
1673ENDIF
1674
1675END FUNCTION int_to_char
1676
1677
1678FUNCTION trim_int_to_char(in) RESULT(char)
1679INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1680CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1681
1682char = to_char(in)
1683
1684END FUNCTION trim_int_to_char
1685
1686
1687FUNCTION trim_int_to_char_miss(in, miss) RESULT(char)
1688INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
1689CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1690CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1691
1692char = to_char(in, miss=miss)
1693
1694END FUNCTION trim_int_to_char_miss
1695
1696
1697! Version with 1-byte integer argument, please use the generic \a to_char
1698! rather than this function directly.
1699ELEMENTAL FUNCTION byte_to_char(in, miss, form) RESULT(char)
1700INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1701CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1702CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1703CHARACTER(len=11) :: char
1704
1705IF (PRESENT(miss)) THEN
1706 IF (.NOT.c_e(in)) THEN
1707 char = miss
1708 ELSE
1709 IF (PRESENT(form)) THEN
1710 WRITE(char,form)in
1711 ELSE
1712 WRITE(char,'(I0)')in
1713 ENDIF
1714 ENDIF
1715ELSE
1716 IF (PRESENT(form)) THEN
1717 WRITE(char,form)in
1718 ELSE
1719 WRITE(char,'(I0)')in
1720 ENDIF
1721ENDIF
1722
1723END FUNCTION byte_to_char
1724
1725
1726FUNCTION trim_byte_to_char(in) RESULT(char)
1727INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1728CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1729
1730char = to_char(in)
1731
1732END FUNCTION trim_byte_to_char
1733
1734
1735FUNCTION trim_byte_to_char_miss(in,miss) RESULT(char)
1736INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
1737CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1738CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1739
1740char = to_char(in, miss=miss)
1741
1742END FUNCTION trim_byte_to_char_miss
1743
1744
1745! Version with character argument, please use the generic \a to_char
1746! rather than this function directly. It is almost useless, just
1747! provided for completeness.
1748ELEMENTAL FUNCTION char_to_char(in) RESULT(char)
1749CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1750CHARACTER(len=LEN(in)) :: char
1751
1752char = in
1753
1754END FUNCTION char_to_char
1755
1756
1757ELEMENTAL FUNCTION char_to_char_miss(in, miss) RESULT(char)
1758CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1759CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1760CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
1761
1762IF (c_e(in)) THEN
1763 char = in
1764ELSE
1765 char = miss
1766ENDIF
1767
1768END FUNCTION char_to_char_miss
1769
1770
1771FUNCTION trim_char_to_char(in) result(char)
1772CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1773CHARACTER(len=LEN_TRIM(in)) :: char
1774
1775char = trim(in)
1776
1777END FUNCTION trim_char_to_char
1778
1779
1780FUNCTION trim_char_to_char_miss(in, miss) RESULT(char)
1781CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
1782CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing valu
1783CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
1784
1785char = char_to_char_miss(in, miss)
1786
1787END FUNCTION trim_char_to_char_miss
1788
1789
1790! Version with single precision real argument, please use the generic
1791! \a to_char rather than this function directly.
1792ELEMENTAL FUNCTION real_to_char(in, miss, form) RESULT(char)
1793REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1794CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1795CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1796CHARACTER(len=15) :: char
1797
1798CHARACTER(len=15) :: tmpchar
1799
1800IF (PRESENT(miss)) THEN
1801 IF (.NOT.c_e(in)) THEN
1802 char = miss
1803 ELSE
1804 IF (PRESENT(form)) THEN
1805 WRITE(char,form)in
1806 ELSE
1807 WRITE(tmpchar,'(G15.9)') in
1808 char = adjustl(tmpchar)
1809 ENDIF
1810 ENDIF
1811ELSE
1812 IF (PRESENT(form)) THEN
1813 WRITE(char,form)in
1814 ELSE
1815 WRITE(tmpchar,'(G15.9)') in
1816 char = adjustl(tmpchar)
1817 ENDIF
1818ENDIF
1819
1820END FUNCTION real_to_char
1821
1822
1823FUNCTION trim_real_to_char(in) RESULT(char)
1824REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1825CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1826
1827char = real_to_char(in)
1828
1829END FUNCTION trim_real_to_char
1830
1831
1832FUNCTION trim_real_to_char_miss(in, miss) RESULT(char)
1833REAL,INTENT(in) :: in ! value to be represented as CHARACTER
1834CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1835CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1836
1837char = real_to_char(in, miss=miss)
1838
1839END FUNCTION trim_real_to_char_miss
1840
1841
1842! Version with double precision real argument, please use the generic
1843! \a to_char rather than this function directly.
1844ELEMENTAL FUNCTION double_to_char(in, miss, form) RESULT(char)
1845DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1846CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
1847CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1848CHARACTER(len=24) :: char
1849
1850CHARACTER(len=24) :: tmpchar
1851
1852IF (PRESENT(miss)) THEN
1853 IF (.NOT.c_e(in)) THEN
1854 char = miss
1855 ELSE
1856 IF (PRESENT(form)) THEN
1857 WRITE(char,form)in
1858 ELSE
1859 WRITE(tmpchar,'(G24.17)') in
1860 char = adjustl(tmpchar)
1861 ENDIF
1862 ENDIF
1863ELSE
1864 IF (PRESENT(form)) THEN
1865 WRITE(char,form)in
1866 ELSE
1867 WRITE(tmpchar,'(G24.17)') in
1868 char = adjustl(tmpchar)
1869 ENDIF
1870ENDIF
1871
1872END FUNCTION double_to_char
1873
1874
1875FUNCTION trim_double_to_char(in) RESULT(char)
1876DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1877CHARACTER(len=LEN_TRIM(to_char(in))) :: char
1878
1879char=double_to_char(in)
1880
1881END FUNCTION trim_double_to_char
1882
1883
1884FUNCTION trim_double_to_char_miss(in, miss) RESULT(char)
1885DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
1886CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
1887CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
1888
1889char=double_to_char(in, miss=miss)
1890
1891END FUNCTION trim_double_to_char_miss
1892
1893
1894! Version with logical argument, please use the generic \a to_char
1895! rather than this function directly.
1896ELEMENTAL FUNCTION logical_to_char(in, form) RESULT(char)
1897LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1898CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
1899CHARACTER(len=1) :: char
1900
1901IF (PRESENT(form)) THEN
1902 WRITE(char,form) in
1903ELSE
1904 WRITE(char,'(L1)') in
1905ENDIF
1906
1907END FUNCTION logical_to_char
1908
1909
1910ELEMENTAL FUNCTION trim_logical_to_char(in) RESULT(char)
1911LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
1912
1913CHARACTER(len=1) :: char
1914
1915WRITE(char,'(L1)') in
1916
1917END FUNCTION trim_logical_to_char
1918
1919
1920!> Convert a character string to an integer value if possible.
1921!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
1922!! missing value if the input cannot be converted or is empty or
1923!! missing.
1924ELEMENTAL FUNCTION c2i(string) RESULT(num)
1925CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a INTEGER
1926INTEGER :: num
1927
1928INTEGER :: lier
1929
1930IF (.NOT.c_e(string)) THEN
1931 num = imiss
1932ELSE IF (len_trim(string) == 0) THEN
1933 num = imiss
1934ELSE
1935 READ(string, '(I32)', iostat=lier)num
1936 IF (lier /= 0) THEN
1937 num = imiss
1938 ENDIF
1939ENDIF
1940
1941END FUNCTION c2i
1942
1943
1944!> Convert a character string to a real value if possible.
1945!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
1946!! missing value if the input cannot be converted or is empty or
1947!! missing.
1948ELEMENTAL FUNCTION c2r(string) RESULT(num)
1949CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a REAL
1950REAL :: num
1951
1952INTEGER :: lier
1953
1954IF (.NOT.c_e(string)) THEN
1955 num = rmiss
1956ELSE IF (len_trim(string) == 0) THEN
1957 num = rmiss
1958ELSE
1959 READ(string, '(F32.0)', iostat=lier)num
1960 IF (lier /= 0) THEN
1961 num = rmiss
1962 ENDIF
1963ENDIF
1964
1965END FUNCTION c2r
1966
1967
1968!> Convert a character string to a double value if possible.
1969!! It is \a ELEMENTAL so it works with arrays of any shape. It returns
1970!! missing value if the input cannot be converted or is empty or
1971!! missing.
1972ELEMENTAL FUNCTION c2d(string) RESULT(num)
1973CHARACTER(len=*),INTENT(in) :: string !< string to be represented as \a DOUBLE \a PRECISION
1974DOUBLE PRECISION :: num
1975
1976INTEGER :: lier
1977
1978IF (.NOT.c_e(string)) THEN
1979 num = rmiss
1980ELSE IF (len_trim(string) == 0) THEN
1981 num = rmiss
1982ELSE
1983 READ(string, '(F32.0)', iostat=lier)num
1984 IF (lier /= 0) THEN
1985 num = rmiss
1986 ENDIF
1987ENDIF
1988
1989END FUNCTION c2d
1990
1991
1992!> Converts a \a CHARACTER variable into a string which can be
1993!! directly passed to a C function requiring a null-terminated \a
1994!! const \a char* (input) argument. If the result is going to be
1995!! stored into an array, this has to be dimensioned with a suitable
1996!! size (\a LEN(fchar) \a + \a 1 ).
1997FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
1998CHARACTER(len=*), INTENT(in) :: fchar !< variable to be converted
1999INTEGER(kind=int_b) :: cstr(LEN(fchar)+1)
2000
2001cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
2002cstr(len(fchar)+1) = 0 ! zero-terminate
2003
2004END FUNCTION fchar_to_cstr
2005
2006
2007!> Converts a \a CHARACTER variable into a string which can be
2008!! directly passed to a C function requiring a null-terminated \a
2009!! char* (input/output) argument. The result is stored into \a pcstr
2010!! which is allocated within the subroutine and has to be deallocated
2011!! by the calling procedure.
2012SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
2013CHARACTER(len=*), INTENT(in) :: fchar !< variable to be converted
2014INTEGER(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
2015
2016ALLOCATE(pcstr(len(fchar)+1))
2017pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
2018pcstr(len(fchar)+1) = 0 ! zero-terminate
2019
2020END SUBROUTINE fchar_to_cstr_alloc
2021
2022
2023!> Converts a null-terminated C-style string into a Fortran \a CHARACTER
2024!! variable of the same length, the null termination character is
2025!! removed.
2026FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
2027INTEGER(kind=int_b), INTENT(in) :: cstr(:) !< variable to be converted
2028CHARACTER(len=SIZE(cstr)-1) :: fchar
2029
2030INTEGER :: i
2031
2032!l = MIN(LEN(char), SIZE(cstr)-1)
2033fchar = transfer(cstr(1:SIZE(cstr)-1), fchar)
2034DO i = 1, SIZE(cstr)-1
2035 IF (fchar(i:i) == char(0)) THEN ! truncate if the null terminator is found before
2036 fchar(i:) = ' '
2037 EXIT
2038 ENDIF
2039ENDDO
2040
2041END FUNCTION cstr_to_fchar
2042
2043
2044!> Convert a \a CHARACTER variable to uppercase.
2045FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
2046CHARACTER( * ), INTENT( IN ) :: Input_String !< variable to be converted
2047CHARACTER( LEN( Input_String ) ) :: Output_String
2048 ! -- Local variables
2049INTEGER :: i, n
2050
2051 ! -- Copy input string
2052output_string = input_string
2053 ! -- Loop over string elements
2054DO i = 1, len( output_string )
2055 ! -- Find location of letter in lower case constant string
2056 n = index( lower_case, output_string( i:i ) )
2057 ! -- If current substring is a lower case letter, make it upper case
2058 IF ( n /= 0 ) output_string( i:i ) = upper_case( n:n )
2059END DO
2060END FUNCTION uppercase
2061
2062
2063!> Convert a \a CHARACTER variable to lowercase.
2064FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
2065 ! -- Argument and result
2066CHARACTER( * ), INTENT( IN ) :: Input_String !< variable to be converted
2067CHARACTER( LEN( Input_String ) ) :: Output_String
2068 ! -- Local variables
2069INTEGER :: i, n
2070
2071 ! -- Copy input string
2072output_string = input_string
2073 ! -- Loop over string elements
2074DO i = 1, len( output_string )
2075 ! -- Find location of letter in upper case constant string
2076 n = index( upper_case, output_string( i:i ) )
2077 ! -- If current substring is an upper case letter, make it lower case
2078 IF ( n /= 0 ) output_string( i:i ) = lower_case( n:n )
2079END DO
2080END FUNCTION lowercase
2081
2082
2083!> Returns \a input_string centered, i.e.\ with an equal number of
2084!! leading and trailing blanks (±1 if they are odd). The needed
2085!! number of leading/trailing blanks is added or removed at the
2086!! beginning and/or at the end in order to keep the length of the
2087!! resulting string equal to the input length.
2088ELEMENTAL FUNCTION align_center(input_string) RESULT(aligned)
2089CHARACTER(len=*), INTENT(in) :: input_string !< string to be aligned
2090
2091CHARACTER(len=LEN(input_string)) :: aligned
2092
2093INTEGER :: n1, n2
2094
2095n1 = f_nblnk(input_string)
2096n2 = len(input_string)-l_nblnk(input_string)+1
2097
2098aligned = ''
2099aligned((n1+n2)/2:) = input_string(n1:)
2100
2101END FUNCTION align_center
2102
2103
2104!> Return the index of last character in \a input_string which is not
2105!! a blank space. If the string is zero-length or contains only blank
2106!! spaces, zero is returned. It is named l_nblnk and not lnblnk in
2107!! order to avoid conflict with a nondefault intrinsic Fortran
2108!! function with the same name, available on some compilers.
2109ELEMENTAL FUNCTION l_nblnk(input_string, blnk) RESULT(nblnk)
2110CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2111CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk !< optional blank character, if not provided, a blank space is assumed
2112
2113CHARACTER(len=1) :: lblnk
2114INTEGER :: nblnk
2115
2116IF (PRESENT(blnk)) THEN
2117 lblnk = blnk
2118ELSE
2119 lblnk = ' '
2120ENDIF
2121
2122DO nblnk = len(input_string), 1, -1
2123 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
2124ENDDO
2125
2126END FUNCTION l_nblnk
2127
2128
2129!> Return the index of first character in \a input_string which is not
2130!! a blank space. If the string is zero-length or contains only blank
2131!! spaces, \a LEN(input_string)+1 is returned.
2132ELEMENTAL FUNCTION f_nblnk(input_string, blnk) RESULT(nblnk)
2133CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2134CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk !< optional blank character, if not provided, a blank space is assumed
2135
2136CHARACTER(len=1) :: lblnk
2137INTEGER :: nblnk
2138
2139IF (PRESENT(blnk)) THEN
2140 lblnk = blnk
2141ELSE
2142 lblnk = ' '
2143ENDIF
2144
2145DO nblnk = 1, len(input_string)
2146 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
2147ENDDO
2148
2149END FUNCTION f_nblnk
2150
2151
2152!> Split a line into words at a predefined character (default blank).
2153!! Returns the number of words in \a input_string. If pointers \a
2154!! word_start and \a word_end are provided, they are allocated with \a
2155!! nword elements and set to the indices of initial and final
2156!! character of every word in \a input_string. Groups of contiguous
2157!! separation characters are treated as a single separator character.
2158FUNCTION word_split(input_string, word_start, word_end, sep) RESULT(nword)
2159CHARACTER(len=*), INTENT(in) :: input_string !< string to be scanned
2160INTEGER, POINTER, OPTIONAL :: word_start(:) !< indices of first character of each word in \a input_string, allocated here, must be deallocated by the user
2161INTEGER, POINTER, OPTIONAL :: word_end(:) !< indices of last character of each word in \a input_string, allocated here, must be deallocated by the user
2162CHARACTER(len=1), OPTIONAL :: sep !< optional word separator character, if not provided, a blank space is assumed
2163
2164INTEGER :: nword
2165
2166INTEGER :: ls, le
2167INTEGER, POINTER :: lsv(:), lev(:)
2168CHARACTER(len=1) :: lsep
2169
2170IF (PRESENT(sep)) THEN
2171 lsep = sep
2172ELSE
2173 lsep = ' '
2174ENDIF
2175
2176nword = 0
2177le = 0
2178DO WHILE(.true.)
2179 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2180 IF (ls > len(input_string)) EXIT ! end of words
2181 le = index(input_string(ls:), lsep)
2182 IF (le == 0) THEN
2183 le = len(input_string)
2184 ELSE
2185 le = le + ls - 2
2186 ENDIF
2187 nword = nword + 1
2188ENDDO
2189
2190IF (.NOT.PRESENT(word_start) .AND. .NOT.PRESENT(word_end)) RETURN
2191
2192ALLOCATE(lsv(nword), lev(nword))
2193nword = 0
2194le = 0
2195DO WHILE(.true.)
2196 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
2197 IF (ls > len(input_string)) EXIT ! end of words
2198 le = index(input_string(ls:), lsep)
2199 IF (le == 0) THEN
2200 le = len(input_string)
2201 ELSE
2202 le = le + ls - 2
2203 ENDIF
2204 nword = nword + 1
2205 lsv(nword) = ls
2206 lev(nword) = le
2207ENDDO
2208
2209IF (PRESENT(word_start)) THEN
2210 word_start => lsv
2211ELSE
2212 DEALLOCATE(lsv)
2213ENDIF
2214IF (PRESENT(word_end)) THEN
2215 word_end => lev
2216ELSE
2217 DEALLOCATE(lev)
2218ENDIF
2219
2220END FUNCTION word_split
2221
2222
2223!> Constructor for the \a line_split class. It creates a new object
2224!! allowing to split a line of text into multiple lines of predefined
2225!! length at blank spaces. If a line can't be splitted because a word
2226!! is longer than the line, it is truncated.
2227FUNCTION line_split_new(line, ncols) RESULT(this)
2228CHARACTER(len=*), INTENT(in) :: line !< line to be splitted
2229INTEGER, INTENT(in), OPTIONAL :: ncols !< maximum number of columns on every line, if not provided a suitable default is used
2230
2231TYPE(line_split) :: this
2232
2233INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
2234
2235IF (PRESENT(ncols)) THEN
2236 this%ncols = ncols
2237ELSE
2238 this%ncols = default_columns()
2239ENDIF
2240! split the input line
2241nwords = word_split(line, this%word_start, this%word_end)
2242! count the lines required to accomodate the input line in a paragraph
2243nlines = 0
2244nw = 0
2245DO WHILE(nw < nwords)
2246 columns_in_line = 0
2247 words_in_line = 0
2248 DO WHILE(nw < nwords)
2249 nw = nw + 1
2250 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2251 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2252 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2253 words_in_line == 0) THEN ! accept the word
2254 columns_in_line = columns_in_line + ncols_next_word
2255 words_in_line = words_in_line + 1
2256 ELSE ! refuse the word
2257 nw = nw - 1
2258 EXIT
2259 ENDIF
2260 ENDDO
2261 nlines = nlines + 1
2262ENDDO
2263
2264!IF (nlines == 0)
2265ALLOCATE(this%paragraph(this%ncols, nlines))
2266this%paragraph = ' '
2267! repeat filling the paragraph
2268nlines = 0
2269nw = 0
2270DO WHILE(nw < nwords)
2271 columns_in_line = 0
2272 words_in_line = 0
2273 DO WHILE(nw < nwords)
2274 nw = nw + 1
2275 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
2276 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1 ! previous space
2277 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
2278 words_in_line == 0) THEN ! accept the word
2279 columns_in_line = columns_in_line + ncols_next_word
2280! now fill the paragraph
2281 IF (columns_in_line <= this%ncols) THEN ! non truncated line
2282 IF (words_in_line > 0) THEN ! previous space
2283 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2284 transfer(' '//line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2285 ELSE ! no previous space
2286 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
2287 transfer(line(this%word_start(nw):this%word_end(nw)), this%paragraph)
2288 ENDIF
2289 ELSE ! truncated line (word longer than line)
2290 this%paragraph(1:this%ncols,nlines+1) = &
2291 transfer(line(this%word_start(nw):this%word_start(nw)+this%ncols-1), this%paragraph)
2292 ENDIF
2293 words_in_line = words_in_line + 1
2294 ELSE ! refuse the word
2295 nw = nw - 1
2296 EXIT
2297 ENDIF
2298 ENDDO
2299 nlines = nlines + 1
2300ENDDO
2301
2302END FUNCTION line_split_new
2303
2304
2305! Cleanly destroy a \a line_split object, deallocating all the
2306! dynamically allocated space. Use the generic name \a delete rather
2307! than this specfoc subroutine.
2308SUBROUTINE line_split_delete(this)
2309TYPE(line_split), INTENT(inout) :: this ! object to be destroyed
2310
2311IF (ASSOCIATED(this%paragraph)) DEALLOCATE(this%paragraph)
2312IF (ASSOCIATED(this%word_start)) DEALLOCATE(this%word_start)
2313IF (ASSOCIATED(this%word_end)) DEALLOCATE(this%word_end)
2314
2315END SUBROUTINE line_split_delete
2316
2317
2318!> Return the number of lines over which the input line was splitted.
2319FUNCTION line_split_get_nlines(this) RESULT(nlines)
2320TYPE(line_split), INTENT(in) :: this !< object initialised with the line to be splitted
2321
2322INTEGER :: nlines
2323
2324IF (ASSOCIATED(this%paragraph)) THEN
2325 nlines = SIZE(this%paragraph, 2)
2326ELSE
2327 nlines = 0
2328ENDIF
2329
2330END FUNCTION line_split_get_nlines
2331
2332
2333!> Return the \a nline-th line obtained after splitting. If \a nline
2334!! is out of range, a missing value is returned. The line is always
2335!! left-aligned and it is padded with trailing blanks up to the
2336!! requested line length.
2337FUNCTION line_split_get_line(this, nline) RESULT(line)
2338TYPE(line_split), INTENT(in) :: this !< object initialised with the line to be splitted
2339INTEGER, INTENT(in) :: nline !< index of the line to be returned
2340
2341CHARACTER(len=SIZE(this%paragraph, 1)) :: line
2342IF (nline > 0 .AND. nline <= SIZE(this%paragraph, 2)) THEN
2343 line = transfer(this%paragraph(:,nline), line)
2344ELSE
2345 line = cmiss
2346ENDIF
2347
2348END FUNCTION line_split_get_line
2349
2350
2351!> Return the number of columns in the terminal, if available it is
2352!! taken from the \a COLUMNS environment variable (it may be necessary
2353!! to execute \c export \c COLUMNS before running the program, in
2354!! order for this to work), otherwise it is set to 80. A positive
2355!! value is returned in any case
2356FUNCTION default_columns() RESULT(cols)
2357INTEGER :: cols
2358
2359INTEGER, PARAMETER :: defaultcols = 80 ! default of the defaults
2360INTEGER, PARAMETER :: maxcols = 256 ! maximum value
2361CHARACTER(len=10) :: ccols
2362
2363cols = defaultcols
2364CALL getenv('COLUMNS', ccols)
2365IF (ccols == '') RETURN
2366
2367READ(ccols, '(I10)', err=100) cols
2368cols = min(cols, maxcols)
2369IF (cols <= 0) cols = defaultcols
2370RETURN
2371
2372100 cols = defaultcols ! error in reading the value
2373
2374END FUNCTION default_columns
2375
2376
2377!> Return the suffix of a filename.
2378FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
2379! -- Argument and result
2380CHARACTER( * ), INTENT( IN ) :: Input_String !< string to be interpreted as a filename
2381CHARACTER( LEN( Input_String ) ) :: Output_String
2382! -- Local variables
2383INTEGER :: i
2384
2385output_string=""
2386i = index(input_string,".",back=.true.)
2387if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
2388
2389END FUNCTION suffixname
2390
2391
2392!> Remove the requested characters from a string.
2393!! This function returns a string cleaned from unwanted characters,
2394!! either by removing "bad" characters (argument \a badchar) or by
2395!! keeping only "good" characters (argument \a goodchar). If neither
2396!! \a badchar nor \a goodchar are provided, it keeps only alphabetic
2397!! ASCII characters.
2398ELEMENTAL FUNCTION wash_char(in, goodchar, badchar) RESULT(char)
2399CHARACTER(len=*),INTENT(in) :: in !< string to be cleaned
2400CHARACTER(len=*),INTENT(in),OPTIONAL :: badchar !< optional set of "bad" characters
2401CHARACTER(len=*),INTENT(in),OPTIONAL :: goodchar !< optional set of "good" characters
2402integer,allocatable :: igoodchar(:)
2403integer,allocatable :: ibadchar(:)
2404
2405CHARACTER(len=len(in)) :: char,charr,charrr
2406INTEGER :: i,ia,nchar
2407
2408char=""
2409charr=""
2410charrr=""
2411
2412if (present(goodchar)) then
2413
2414allocate(igoodchar(len(goodchar)))
2415
2416 do i =1, len(goodchar)
2417 igoodchar=ichar(goodchar(i:i))
2418 end do
2419
2420 nchar=0
2421 do i=1,len(in)
2422 ia = ichar(in(i:i))
2423 if (any(ia == igoodchar))then
2424 nchar=nchar+1
2425 charrr(nchar:nchar)=achar(ia)
2426 end if
2427 end do
2428
2429deallocate(igoodchar)
2430
2431else
2432
2433 charrr=in
2434
2435end if
2436
2437
2438
2439if (present(badchar)) then
2440
2441allocate(ibadchar(len(badchar)))
2442
2443 do i =1, len(badchar)
2444 ibadchar=ichar(badchar(i:i))
2445 end do
2446
2447 nchar=0
2448 do i=1,len(charrr)
2449 ia = ichar(charrr(i:i))
2450 if (.not. any(ia == ibadchar))then
2451 nchar=nchar+1
2452 charr(nchar:nchar)=achar(ia)
2453 end if
2454 end do
2455
2456deallocate(ibadchar)
2457
2458else
2459
2460 charr=charrr
2461
2462end if
2463
2464
2465if (.not. present(goodchar) .and. .not. present(badchar)) then
2466
2467 nchar=0
2468 do i=1,len(charr)
2469 ia = ichar(charr(i:i))
2470 if ((ia >= 65 .and. ia <= 90) .or. &
2471 (ia >= 97 .and. ia <= 122))then
2472 nchar=nchar+1
2473 char(nchar:nchar)=achar(ia)
2474 end if
2475 end do
2476
2477else
2478
2479 char=charr
2480
2481end if
2482
2483
2484END FUNCTION wash_char
2485
2486
2487! derived by http://sourceforge.net/projects/flibs
2488!
2489! globmatch.f90 --
2490! Match strings according to (simplified) glob patterns
2491!
2492! The pattern matching is limited to literals, * and ?
2493! (character classes are not supported). A backslash escapes
2494! any character.
2495!
2496! $Id: globmatch.f90,v 1.5 2006/03/26 19:03:53 arjenmarkus Exp $
2497!!$Copyright (c) 2008, Arjen Markus
2498!!$
2499!!$All rights reserved.
2500!!$
2501!!$Redistribution and use in source and binary forms, with or without modification,
2502!!$are permitted provided that the following conditions are met:
2503!!$
2504!!$Redistributions of source code must retain the above copyright notice,
2505!!$this list of conditions and the following disclaimer.
2506!!$Redistributions in binary form must reproduce the above copyright notice,
2507!!$this list of conditions and the following disclaimer in the documentation
2508!!$and/or other materials provided with the distribution.
2509!!$Neither the name of the author nor the names of the contributors
2510!!$may be used to endorse or promote products derived from this software
2511!!$without specific prior written permission.
2512!!$THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2513!!$"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
2514!!$THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
2515!!$ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
2516!!$FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
2517!!$DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
2518!!$SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2519!!$CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
2520!!$OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
2521!!$OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2522!
2523
2524!> Tries to match the given string with the pattern (array version).
2525!! Returns \a .TRUE. if the entire string matches the pattern, \a
2526!! .FALSE. otherwise. Note: trailing blanks are ignored.
2527function string_match_v( string, pattern ) result(match)
2528character(len=*), intent(in) :: string(:) !< string to be examined
2529character(len=*), intent(in) :: pattern !< glob pattern to be used for the matching
2530logical :: match(size(string))
2531
2532integer :: i
2533
2534do i =1,size(string)
2535 match(i)=string_match(string(i),pattern)
2536end do
2537
2538end function string_match_v
2539
2540
2541!> Tries to match the given string with the pattern.
2542!! Returns \a .TRUE. if the entire string matches the pattern, \a
2543!! .FALSE. otherwise. Note: trailing blanks are ignored.
2544recursive function string_match( string, pattern ) result(match)
2545 character(len=*), intent(in) :: string !< String to be examined
2546 character(len=*), intent(in) :: pattern !< Glob pattern to be used for the matching
2547 logical :: match
2548
2549! '\\' without -fbackslash generates a warning on gfortran, '\'
2550! crashes doxygen, so we choose '\\' and -fbackslash in configure.ac
2551 character(len=1), parameter :: backslash = '\\'
2552 character(len=1), parameter :: star = '*'
2553 character(len=1), parameter :: question = '?'
2554
2555 character(len=len(pattern)) :: literal
2556 integer :: ptrim
2557 integer :: p
2558 integer :: k
2559 integer :: ll
2560 integer :: method
2561 integer :: start
2562 integer :: strim
2563
2564 match = .false.
2565 method = 0
2566 ptrim = len_trim( pattern )
2567 strim = len_trim( string )
2568 p = 1
2569 ll = 0
2570 start = 1
2571
2572 !
2573 ! Split off a piece of the pattern
2574 !
2575 do while ( p <= ptrim )
2576 select case ( pattern(p:p) )
2577 case( star )
2578 if ( ll .ne. 0 ) exit
2579 method = 1
2580 case( question )
2581 if ( ll .ne. 0 ) exit
2582 method = 2
2583 start = start + 1
2584 case( backslash )
2585 p = p + 1
2586 ll = ll + 1
2587 literal(ll:ll) = pattern(p:p)
2588 case default
2589 ll = ll + 1
2590 literal(ll:ll) = pattern(p:p)
2591 end select
2592
2593 p = p + 1
2594 enddo
2595
2596 !
2597 ! Now look for the literal string (if any!)
2598 !
2599 if ( method == 0 ) then
2600 !
2601 ! We are at the end of the pattern, and of the string?
2602 !
2603 if ( strim == 0 .and. ptrim == 0 ) then
2604 match = .true.
2605 else
2606 !
2607 ! The string matches a literal part?
2608 !
2609 if ( ll > 0 ) then
2610 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2611 start = start + ll
2612 match = string_match( string(start:), pattern(p:) )
2613 endif
2614 endif
2615 endif
2616 endif
2617
2618 if ( method == 1 ) then
2619 !
2620 ! Scan the whole of the remaining string ...
2621 !
2622 if ( ll == 0 ) then
2623 match = .true.
2624 else
2625 do while ( start <= strim )
2626 k = index( string(start:), literal(1:ll) )
2627 if ( k > 0 ) then
2628 start = start + k + ll - 1
2629 match = string_match( string(start:), pattern(p:) )
2630 if ( match ) then
2631 exit
2632 endif
2633 endif
2634
2635 start = start + 1
2636 enddo
2637 endif
2638 endif
2639
2640 if ( method == 2 .and. ll > 0 ) then
2641 !
2642 ! Scan the whole of the remaining string ...
2643 !
2644 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
2645 match = string_match( string(start+ll:), pattern(p:) )
2646 endif
2647 endif
2648 return
2649end function string_match
2650
2651
2652SUBROUTINE print_status_line(line)
2653CHARACTER(len=*),INTENT(in) :: line
2654CHARACTER(len=1),PARAMETER :: cr=char(13)
2655WRITE(stdout_unit,'(2A)',advance='no')cr,trim(line)
2656FLUSH(unit=6) ! probably useless with gfortran, required with Intel fortran
2657END SUBROUTINE print_status_line
2658
2659SUBROUTINE done_status_line()
2660WRITE(stdout_unit,'()')
2661END SUBROUTINE done_status_line
2662
2663
2664!> Update a progress line with a new value.
2665!! This subroutine updates the progress line object with a new double
2666!! precision value \a val. Values outside the range \a this%min, \a
2667!! this%max are truncated. If \a val is equal or greter maximum the
2668!! progress bar is closed so that a new line can be printed. When a
2669!! progress_line object reaches its maximum it can no more be updated
2670!! and/or closed. Use the interface method \a update rather than this
2671!! subroutine directly.
2672SUBROUTINE progress_line_update_d(this, val)
2673CLASS(progress_line),INTENT(inout) :: this !< progress_line object to be updated
2674DOUBLE PRECISION,INTENT(in) :: val !< new value
2675
2676INTEGER :: vint, i
2677CHARACTER(len=512) :: line
2678
2679IF (this%curr >= this%max) RETURN ! line is already closed, do nothing
2680
2681this%curr = max(this%min, min(this%max, val))
2682this%spin = mod(this%spin+1, 4)
2683line = ''
2684
2685vint = nint((this%curr-this%min)/(this%max-this%min)*100.d0)
2686WRITE(line,this%form)vint, &
2687 progress_line_spin(this%spin+1:this%spin+1)
2688vint = vint/10
2689
2690DO i = 1, vint
2691 line(this%barloc+i:this%barloc+i) = this%done
2692ENDDO
2693DO i = vint+1, 10
2694 line(this%barloc+i:this%barloc+i) = this%todo
2695ENDDO
2696CALL print_status_line(line)
2697IF (this%curr >= this%max) CALL done_status_line()
2698
2699END SUBROUTINE progress_line_update_d
2700
2701
2702!> Update a progress line with a new value.
2703!! This subroutine is equivalent to \a progress_line_update_d but it
2704!! accepts an inteer value \a val. Use the interface method \a update
2705!! rather than this subroutine directly.
2706SUBROUTINE progress_line_update_i(this, val)
2707CLASS(progress_line),INTENT(inout) :: this !< progress_line object to be updated
2708INTEGER,INTENT(in) :: val !< new value
2709
2710CALL progress_line_update_d(this, dble(val))
2711
2712END SUBROUTINE progress_line_update_i
2713
2714!> Close artificially the progress_line object.
2715!! This subroutine forces the progress_line object to be closed
2716!! regardless of the value reached by the progress counter. It does
2717!! not need to be called if the \a update method has already been
2718!! called with the maximum progress value.
2719SUBROUTINE progress_line_alldone(this)
2720CLASS(progress_line),INTENT(inout) :: this
2721CALL progress_line_update_d(this, this%max)
2722END SUBROUTINE progress_line_alldone
2723
2724
2725END 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.