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