libsim Versione 7.2.1

◆ optionparser_add_sep()

subroutine, public optionparser_add_sep ( type(optionparser), intent(inout) this,
character(len=*) help )

Add a new separator option, with a text.

This is a dummy option that inserts a separator line with a text within the list of options when the help is printed. It is useful to insert a visual separator between options or an explanation which is not associated with a specific options but applies to all the subsequent options. The text provided will be formatted into many lines if necessary. Any number of separator options can be added within the option list; they have no effect on the interpretation of the options associated with the optionparser object.

Parametri
[in,out]thisoptionparser object
helpthe help message that will be formatted and pretty-printed on screen

Definizione alla linea 1496 del file optionparser_class.F90.

1497! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1498! authors:
1499! Davide Cesari <dcesari@arpa.emr.it>
1500! Paolo Patruno <ppatruno@arpa.emr.it>
1501
1502! This program is free software; you can redistribute it and/or
1503! modify it under the terms of the GNU General Public License as
1504! published by the Free Software Foundation; either version 2 of
1505! the License, or (at your option) any later version.
1506
1507! This program is distributed in the hope that it will be useful,
1508! but WITHOUT ANY WARRANTY; without even the implied warranty of
1509! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1510! GNU General Public License for more details.
1520#include "config.h"
1521
1522MODULE optionparser_class
1523USE log4fortran
1524USE err_handling
1525USE kinds
1529IMPLICIT NONE
1530
1531
1532! private class
1533TYPE option
1534 CHARACTER(len=1) :: short_opt=''
1535 CHARACTER(len=80) :: long_opt=''
1536 INTEGER :: opttype=-1
1537 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1538 LOGICAL :: has_default=.false.
1539 CHARACTER(len=1),POINTER :: destc=>null()
1540 INTEGER :: destclen=0
1541 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1542 INTEGER,POINTER :: desti=>null()
1543 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1544 REAL,POINTER :: destr=>null()
1545 TYPE(arrayof_real),POINTER :: destrarr=>null()
1546 DOUBLE PRECISION, POINTER :: destd=>null()
1547 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1548 LOGICAL,POINTER :: destl=>null()
1549 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1550 INTEGER,POINTER :: destcount=>null()
1551 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1552END TYPE option
1553
1554#define ARRAYOF_ORIGTYPE TYPE(option)
1555#define ARRAYOF_TYPE arrayof_option
1556#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1557#define ARRAYOF_PRIVATE 1
1558#include "arrayof_pre_nodoc.F90"
1559! from arrayof
1560!PUBLIC insert, append, remove, packarray
1561!PUBLIC insert_unique, append_unique
1562
1640TYPE optionparser
1641 PRIVATE
1642 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1643 TYPE(arrayof_option) :: options
1644 LOGICAL :: httpmode=.false.
1645END TYPE optionparser
1646
1647
1651INTERFACE optionparser_add
1652 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1653 optionparser_add_d, optionparser_add_l, &
1654 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1655END INTERFACE
1656
1657INTERFACE c_e
1658 MODULE PROCEDURE option_c_e
1659END INTERFACE
1660
1668INTERFACE delete
1669 MODULE PROCEDURE optionparser_delete!?, option_delete
1670END INTERFACE
1671
1672
1673INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1674 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1675 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1676 opttype_darr = 14, opttype_larr = 15
1677
1678INTEGER,PARAMETER :: optionparser_ok = 0
1679INTEGER,PARAMETER :: optionparser_help = 1
1680INTEGER,PARAMETER :: optionparser_err = 2
1681
1682
1683PRIVATE
1684PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1685 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1686 optionparser_parse, optionparser_printhelp, &
1687 optionparser_ok, optionparser_help, optionparser_err
1688
1689
1690CONTAINS
1691
1692#include "arrayof_post_nodoc.F90"
1693
1694! Constructor for the option class
1695FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1696CHARACTER(len=*),INTENT(in) :: short_opt
1697CHARACTER(len=*),INTENT(in) :: long_opt
1698CHARACTER(len=*),INTENT(in) :: default
1699CHARACTER(len=*),OPTIONAL :: help
1700TYPE(option) :: this
1701
1702IF (short_opt == '' .AND. long_opt == '') THEN
1703#ifdef DEBUG
1704! programmer error condition, option empty
1705 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1706 CALL raise_fatal_error()
1707#else
1708 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1709#endif
1710 RETURN
1711ENDIF
1712
1713this%short_opt = short_opt
1714this%long_opt = long_opt
1715IF (PRESENT(help)) THEN
1716 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1717ENDIF
1718this%has_default = (len_trim(default) > 0)
1719
1720END FUNCTION option_new
1721
1722
1723! Destructor for the \a option class, the memory associated with
1724! the object is freed.
1725SUBROUTINE option_delete(this)
1726TYPE(option),INTENT(inout) :: this ! object to destroy
1727
1728IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1729NULLIFY(this%destc)
1730NULLIFY(this%desti)
1731NULLIFY(this%destr)
1732NULLIFY(this%destd)
1733NULLIFY(this%destl)
1734NULLIFY(this%destcount)
1735
1736END SUBROUTINE option_delete
1737
1738
1739FUNCTION option_found(this, optarg) RESULT(status)
1740TYPE(option),INTENT(inout) :: this
1741CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1742INTEGER :: status
1743
1744TYPE(csv_record) :: arrparser
1745INTEGER :: ibuff
1746REAL :: rbuff
1747DOUBLE PRECISION :: dbuff
1748
1749status = optionparser_ok
1750
1751SELECT CASE(this%opttype)
1752CASE(opttype_c)
1753 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1754! this%destc(1:this%destclen) = optarg
1755 IF (len_trim(optarg) > this%destclen) THEN
1756 CALL l4f_log(l4f_warn, &
1757 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1758 ENDIF
1759CASE(opttype_i)
1760 READ(optarg,'(I12)',err=100)this%desti
1761CASE(opttype_iarr)
1762 CALL delete(this%destiarr) ! delete default values
1763 CALL init(arrparser, optarg)
1764 DO WHILE(.NOT.csv_record_end(arrparser))
1765 CALL csv_record_getfield(arrparser, ibuff)
1766 CALL insert(this%destiarr, ibuff)
1767 ENDDO
1768 CALL packarray(this%destiarr)
1769 CALL delete(arrparser)
1770CASE(opttype_r)
1771 READ(optarg,'(F20.0)',err=102)this%destr
1772CASE(opttype_rarr)
1773 CALL delete(this%destrarr) ! delete default values
1774 CALL init(arrparser, optarg)
1775 DO WHILE(.NOT.csv_record_end(arrparser))
1776 CALL csv_record_getfield(arrparser, rbuff)
1777 CALL insert(this%destrarr, rbuff)
1778 ENDDO
1779 CALL packarray(this%destrarr)
1780 CALL delete(arrparser)
1781CASE(opttype_d)
1782 READ(optarg,'(F20.0)',err=102)this%destd
1783CASE(opttype_darr)
1784 CALL delete(this%destdarr) ! delete default values
1785 CALL init(arrparser, optarg)
1786 DO WHILE(.NOT.csv_record_end(arrparser))
1787 CALL csv_record_getfield(arrparser, dbuff)
1788 CALL insert(this%destdarr, dbuff)
1789 ENDDO
1790 CALL packarray(this%destdarr)
1791 CALL delete(arrparser)
1792CASE(opttype_l)
1793 this%destl = .true.
1794CASE(opttype_count)
1795 this%destcount = this%destcount + 1
1796CASE(opttype_help)
1797 status = optionparser_help
1798 SELECT CASE(optarg) ! set help format
1799 CASE('md', 'markdown')
1800 this%helpformat = 1
1801 CASE('htmlform')
1802 this%helpformat = 2
1803 END SELECT
1804END SELECT
1805
1806RETURN
1807
1808100 status = optionparser_err
1809CALL l4f_log(l4f_error, &
1810 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1811RETURN
1812102 status = optionparser_err
1813CALL l4f_log(l4f_error, &
1814 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1815RETURN
1816
1817END FUNCTION option_found
1818
1819
1820! Return a string which gives a short representation of the
1821! option \a this, without help message. The resulting string is quite
1822! long and it should be trimmed with the \a TRIM() intrinsic
1823! function.
1824FUNCTION option_format_opt(this) RESULT(format_opt)
1825TYPE(option),INTENT(in) :: this
1826
1827CHARACTER(len=100) :: format_opt
1828
1829CHARACTER(len=20) :: argname
1830
1831SELECT CASE(this%opttype)
1832CASE(opttype_c)
1833 argname = 'STRING'
1834CASE(opttype_i)
1835 argname = 'INT'
1836CASE(opttype_iarr)
1837 argname = 'INT[,INT...]'
1838CASE(opttype_r, opttype_d)
1839 argname = 'REAL'
1840CASE(opttype_rarr, opttype_darr)
1841 argname = 'REAL[,REAL...]'
1842CASE default
1843 argname = ''
1844END SELECT
1845
1846format_opt = ''
1847IF (this%short_opt /= '') THEN
1848 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1849 IF (argname /= '') THEN
1850 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1851 ENDIF
1852ENDIF
1853IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1854 format_opt(len_trim(format_opt)+1:) = ','
1855ENDIF
1856IF (this%long_opt /= '') THEN
1857 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1858 IF (argname /= '') THEN
1859 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1860 ENDIF
1861ENDIF
1862
1863END FUNCTION option_format_opt
1864
1865
1866! print on stdout a human-readable text representation of a single option
1867SUBROUTINE option_format_help(this, ncols)
1868TYPE(option),INTENT(in) :: this
1869INTEGER,INTENT(in) :: ncols
1870
1871INTEGER :: j
1872INTEGER, PARAMETER :: indent = 10
1873TYPE(line_split) :: help_line
1874
1875
1876IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1877 IF (ALLOCATED(this%help_msg)) THEN
1878! help2man is quite picky about the treatment of arbitrary lines
1879! within options, the only universal way seems to be unindented lines
1880! with an empty line before and after
1881 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1882 WRITE(*,'()')
1883 DO j = 1, line_split_get_nlines(help_line)
1884 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1885 ENDDO
1886 CALL delete(help_line)
1887 WRITE(*,'()')
1888 ENDIF
1889ELSE ! ordinary option
1890! print option brief representation
1891 WRITE(*,'(A)')trim(option_format_opt(this))
1892! print option help
1893 IF (ALLOCATED(this%help_msg)) THEN
1894 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1895 DO j = 1, line_split_get_nlines(help_line)
1896 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1897 ENDDO
1898 CALL delete(help_line)
1899 ENDIF
1900ENDIF
1901
1902END SUBROUTINE option_format_help
1903
1904
1905! print on stdout a markdown representation of a single option
1906SUBROUTINE option_format_md(this, ncols)
1907TYPE(option),INTENT(in) :: this
1908INTEGER,INTENT(in) :: ncols
1909
1910INTEGER :: j
1911INTEGER, PARAMETER :: indent = 2
1912TYPE(line_split) :: help_line
1913
1914IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1915 IF (ALLOCATED(this%help_msg)) THEN
1916 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1917 WRITE(*,'()')
1918 DO j = 1, line_split_get_nlines(help_line)
1919 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1920 ENDDO
1921 CALL delete(help_line)
1922 WRITE(*,'()')
1923 ENDIF
1924ELSE ! ordinary option
1925! print option brief representation
1926 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1927! print option help
1928 IF (ALLOCATED(this%help_msg)) THEN
1929 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1930 DO j = 1, line_split_get_nlines(help_line)
1931 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1932 ENDDO
1933 CALL delete(help_line)
1934 WRITE(*,'()')
1935 ENDIF
1936ENDIF
1937
1938END SUBROUTINE option_format_md
1939
1940
1941! print on stdout an html form representation of a single option
1942SUBROUTINE option_format_htmlform(this)
1943TYPE(option),INTENT(in) :: this
1944
1945CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1946
1947IF (.NOT.c_e(this)) RETURN
1948IF (this%long_opt == '') THEN
1949 opt_name = this%short_opt
1950 opt_id = 'short_opt_'//this%short_opt
1951ELSE
1952 opt_name = this%long_opt
1953 opt_id = this%long_opt
1954ENDIF
1955
1956SELECT CASE(this%opttype)
1957CASE(opttype_c)
1958 CALL option_format_html_openspan('text')
1959
1960 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1961! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1962! opt_default) ! improve
1963 opt_default = ''
1964 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1965 ENDIF
1966 CALL option_format_html_help()
1967 CALL option_format_html_closespan()
1968
1969CASE(opttype_i,opttype_r,opttype_d)
1970 CALL option_format_html_openspan('text')
1971 IF (this%has_default) THEN
1972 SELECT CASE(this%opttype)
1973 CASE(opttype_i)
1974 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
1975! todo CASE(opttype_iarr)
1976 CASE(opttype_r)
1977 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
1978 CASE(opttype_d)
1979 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
1980 END SELECT
1981 ENDIF
1982 CALL option_format_html_help()
1983 CALL option_format_html_closespan()
1984
1985! todo CASE(opttype_iarr)
1986
1987CASE(opttype_l)
1988 CALL option_format_html_openspan('checkbox')
1989 CALL option_format_html_help()
1990 CALL option_format_html_closespan()
1991
1992CASE(opttype_count)
1993 CALL option_format_html_openspan('number')
1994 CALL option_format_html_help()
1995 CALL option_format_html_closespan()
1996
1997CASE(opttype_sep)
1998END SELECT
1999
2000
2001CONTAINS
2002
2003SUBROUTINE option_format_html_openspan(formtype)
2004CHARACTER(len=*),INTENT(in) :: formtype
2005
2006WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2007! size=? maxlen=?
2008WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2009 '" name="'//trim(opt_id)//'" '
2010
2011END SUBROUTINE option_format_html_openspan
2012
2013SUBROUTINE option_format_html_closespan()
2014
2015WRITE(*,'(A)')'/></span>'
2016
2017END SUBROUTINE option_format_html_closespan
2018
2019SUBROUTINE option_format_html_help()
2020INTEGER :: j
2021TYPE(line_split) :: help_line
2022CHARACTER(len=20) :: form
2023
2024IF (ALLOCATED(this%help_msg)) THEN
2025 WRITE(*,'(A,$)')' title="'
2026
2027 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2028 form = '(A,'' '')'
2029 DO j = 1, line_split_get_nlines(help_line)
2030 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2031 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2032 ENDDO
2033
2034ENDIF
2035
2036END SUBROUTINE option_format_html_help
2037
2038END SUBROUTINE option_format_htmlform
2039
2040
2041FUNCTION option_c_e(this) RESULT(c_e)
2042TYPE(option),INTENT(in) :: this
2043
2044LOGICAL :: c_e
2045
2046c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2047
2048END FUNCTION option_c_e
2049
2050
2054FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2055CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2056CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2057
2058TYPE(optionparser) :: this
2059
2060IF (PRESENT(usage_msg)) THEN
2061 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2062ELSE
2063 NULLIFY(this%usage_msg)
2064ENDIF
2065IF (PRESENT(description_msg)) THEN
2066 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2067ELSE
2068 NULLIFY(this%description_msg)
2069ENDIF
2070
2071END FUNCTION optionparser_new
2072
2073
2074SUBROUTINE optionparser_delete(this)
2075TYPE(optionparser),INTENT(inout) :: this
2076
2077IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2078IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2079CALL delete(this%options)
2080
2081END SUBROUTINE optionparser_delete
2082
2083
2091SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2092TYPE(optionparser),INTENT(inout) :: this
2093CHARACTER(len=*),INTENT(in) :: short_opt
2094CHARACTER(len=*),INTENT(in) :: long_opt
2095CHARACTER(len=*),TARGET :: dest
2096CHARACTER(len=*),OPTIONAL :: default
2097CHARACTER(len=*),OPTIONAL :: help
2098LOGICAL,INTENT(in),OPTIONAL :: isopt
2099
2100CHARACTER(LEN=60) :: cdefault
2101INTEGER :: i
2102TYPE(option) :: myoption
2103
2104
2105IF (PRESENT(default)) THEN
2106 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2107ELSE
2108 cdefault = ''
2109ENDIF
2110
2111! common initialisation
2112myoption = option_new(short_opt, long_opt, cdefault, help)
2113IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2114
2115myoption%destc => dest(1:1)
2116myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2117IF (PRESENT(default)) &
2118 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2119!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2120myoption%opttype = opttype_c
2121IF (optio_log(isopt)) THEN
2122 myoption%need_arg = 1
2123ELSE
2124 myoption%need_arg = 2
2125ENDIF
2126
2127i = arrayof_option_append(this%options, myoption)
2128
2129END SUBROUTINE optionparser_add_c
2130
2131
2138SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2139TYPE(optionparser),INTENT(inout) :: this
2140CHARACTER(len=*),INTENT(in) :: short_opt
2141CHARACTER(len=*),INTENT(in) :: long_opt
2142INTEGER,TARGET :: dest
2143INTEGER,OPTIONAL :: default
2144CHARACTER(len=*),OPTIONAL :: help
2145
2146CHARACTER(LEN=40) :: cdefault
2147INTEGER :: i
2148TYPE(option) :: myoption
2149
2150IF (PRESENT(default)) THEN
2151 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2152ELSE
2153 cdefault = ''
2154ENDIF
2155
2156! common initialisation
2157myoption = option_new(short_opt, long_opt, cdefault, help)
2158IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2159
2160myoption%desti => dest
2161IF (PRESENT(default)) myoption%desti = default
2162myoption%opttype = opttype_i
2163myoption%need_arg = 2
2164
2165i = arrayof_option_append(this%options, myoption)
2166
2167END SUBROUTINE optionparser_add_i
2168
2169
2179SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2180TYPE(optionparser),INTENT(inout) :: this
2181CHARACTER(len=*),INTENT(in) :: short_opt
2182CHARACTER(len=*),INTENT(in) :: long_opt
2183TYPE(arrayof_integer),TARGET :: dest
2184INTEGER,OPTIONAL :: default(:)
2185CHARACTER(len=*),OPTIONAL :: help
2186
2187CHARACTER(LEN=40) :: cdefault
2188INTEGER :: i
2189TYPE(option) :: myoption
2190
2191cdefault = ''
2192IF (PRESENT(default)) THEN
2193 IF (SIZE(default) == 1) THEN
2194 cdefault = ' [default='//trim(to_char(default(1)))//']'
2195 ELSE IF (SIZE(default) > 1) THEN
2196 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2197 ENDIF
2198ENDIF
2199
2200! common initialisation
2201myoption = option_new(short_opt, long_opt, cdefault, help)
2202IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2203
2204myoption%destiarr => dest
2205IF (PRESENT(default)) THEN
2206 CALL insert(myoption%destiarr, default)
2207 CALL packarray(myoption%destiarr)
2208ENDIF
2209myoption%opttype = opttype_iarr
2210myoption%need_arg = 2
2211
2212i = arrayof_option_append(this%options, myoption)
2213
2214END SUBROUTINE optionparser_add_iarray
2215
2216
2223SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2224TYPE(optionparser),INTENT(inout) :: this
2225CHARACTER(len=*),INTENT(in) :: short_opt
2226CHARACTER(len=*),INTENT(in) :: long_opt
2227REAL,TARGET :: dest
2228REAL,OPTIONAL :: default
2229CHARACTER(len=*),OPTIONAL :: help
2230
2231CHARACTER(LEN=40) :: cdefault
2232INTEGER :: i
2233TYPE(option) :: myoption
2234
2235IF (PRESENT(default)) THEN
2236 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2237ELSE
2238 cdefault = ''
2239ENDIF
2240
2241! common initialisation
2242myoption = option_new(short_opt, long_opt, cdefault, help)
2243IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2244
2245myoption%destr => dest
2246IF (PRESENT(default)) myoption%destr = default
2247myoption%opttype = opttype_r
2248myoption%need_arg = 2
2249
2250i = arrayof_option_append(this%options, myoption)
2251
2252END SUBROUTINE optionparser_add_r
2253
2254
2264SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2265TYPE(optionparser),INTENT(inout) :: this
2266CHARACTER(len=*),INTENT(in) :: short_opt
2267CHARACTER(len=*),INTENT(in) :: long_opt
2268TYPE(arrayof_real),TARGET :: dest
2269REAL,OPTIONAL :: default(:)
2270CHARACTER(len=*),OPTIONAL :: help
2271
2272CHARACTER(LEN=40) :: cdefault
2273INTEGER :: i
2274TYPE(option) :: myoption
2275
2276cdefault = ''
2277IF (PRESENT(default)) THEN
2278 IF (SIZE(default) == 1) THEN
2279 cdefault = ' [default='//trim(to_char(default(1)))//']'
2280 ELSE IF (SIZE(default) > 1) THEN
2281 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2282 ENDIF
2283ENDIF
2284
2285! common initialisation
2286myoption = option_new(short_opt, long_opt, cdefault, help)
2287IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2288
2289myoption%destrarr => dest
2290IF (PRESENT(default)) THEN
2291 CALL insert(myoption%destrarr, default)
2292 CALL packarray(myoption%destrarr)
2293ENDIF
2294myoption%opttype = opttype_rarr
2295myoption%need_arg = 2
2296
2297i = arrayof_option_append(this%options, myoption)
2298
2299END SUBROUTINE optionparser_add_rarray
2300
2301
2308SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2309TYPE(optionparser),INTENT(inout) :: this
2310CHARACTER(len=*),INTENT(in) :: short_opt
2311CHARACTER(len=*),INTENT(in) :: long_opt
2312DOUBLE PRECISION,TARGET :: dest
2313DOUBLE PRECISION,OPTIONAL :: default
2314CHARACTER(len=*),OPTIONAL :: help
2315
2316CHARACTER(LEN=40) :: cdefault
2317INTEGER :: i
2318TYPE(option) :: myoption
2319
2320IF (PRESENT(default)) THEN
2321 IF (c_e(default)) THEN
2322 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2323 ELSE
2324 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2325 ENDIF
2326ELSE
2327 cdefault = ''
2328ENDIF
2329
2330! common initialisation
2331myoption = option_new(short_opt, long_opt, cdefault, help)
2332IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2333
2334myoption%destd => dest
2335IF (PRESENT(default)) myoption%destd = default
2336myoption%opttype = opttype_d
2337myoption%need_arg = 2
2338
2339i = arrayof_option_append(this%options, myoption)
2340
2341END SUBROUTINE optionparser_add_d
2342
2343
2353SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2354TYPE(optionparser),INTENT(inout) :: this
2355CHARACTER(len=*),INTENT(in) :: short_opt
2356CHARACTER(len=*),INTENT(in) :: long_opt
2357TYPE(arrayof_doubleprecision),TARGET :: dest
2358DOUBLE PRECISION,OPTIONAL :: default(:)
2359CHARACTER(len=*),OPTIONAL :: help
2360
2361CHARACTER(LEN=40) :: cdefault
2362INTEGER :: i
2363TYPE(option) :: myoption
2364
2365cdefault = ''
2366IF (PRESENT(default)) THEN
2367 IF (SIZE(default) == 1) THEN
2368 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2369 ELSE IF (SIZE(default) > 1) THEN
2370 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2371 ENDIF
2372ENDIF
2373
2374! common initialisation
2375myoption = option_new(short_opt, long_opt, cdefault, help)
2376IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2377
2378myoption%destdarr => dest
2379IF (PRESENT(default)) THEN
2380 CALL insert(myoption%destdarr, default)
2381 CALL packarray(myoption%destdarr)
2382ENDIF
2383myoption%opttype = opttype_darr
2384myoption%need_arg = 2
2385
2386i = arrayof_option_append(this%options, myoption)
2387
2388END SUBROUTINE optionparser_add_darray
2389
2390
2397SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2398TYPE(optionparser),INTENT(inout) :: this
2399CHARACTER(len=*),INTENT(in) :: short_opt
2400CHARACTER(len=*),INTENT(in) :: long_opt
2401LOGICAL,TARGET :: dest
2402CHARACTER(len=*),OPTIONAL :: help
2403
2404INTEGER :: i
2405TYPE(option) :: myoption
2406
2407! common initialisation
2408myoption = option_new(short_opt, long_opt, '', help)
2409IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2410
2411myoption%destl => dest
2412myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2413myoption%opttype = opttype_l
2414myoption%need_arg = 0
2415
2416i = arrayof_option_append(this%options, myoption)
2417
2418END SUBROUTINE optionparser_add_l
2419
2420
2425SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2426TYPE(optionparser),INTENT(inout) :: this
2427CHARACTER(len=*),INTENT(in) :: short_opt
2428CHARACTER(len=*),INTENT(in) :: long_opt
2429INTEGER,TARGET :: dest
2430INTEGER,OPTIONAL :: start
2431CHARACTER(len=*),OPTIONAL :: help
2432
2433INTEGER :: i
2434TYPE(option) :: myoption
2435
2436! common initialisation
2437myoption = option_new(short_opt, long_opt, '', help)
2438IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2439
2440myoption%destcount => dest
2441IF (PRESENT(start)) myoption%destcount = start
2442myoption%opttype = opttype_count
2443myoption%need_arg = 0
2444
2445i = arrayof_option_append(this%options, myoption)
2446
2447END SUBROUTINE optionparser_add_count
2448
2449
2464SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2465TYPE(optionparser),INTENT(inout) :: this
2466CHARACTER(len=*),INTENT(in) :: short_opt
2467CHARACTER(len=*),INTENT(in) :: long_opt
2468CHARACTER(len=*),OPTIONAL :: help
2469
2470INTEGER :: i
2471TYPE(option) :: myoption
2472
2473! common initialisation
2474myoption = option_new(short_opt, long_opt, '', help)
2475IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2476
2477myoption%opttype = opttype_help
2478myoption%need_arg = 1
2479
2480i = arrayof_option_append(this%options, myoption)
2481
2482END SUBROUTINE optionparser_add_help
2483
2484
2495SUBROUTINE optionparser_add_sep(this, help)
2496TYPE(optionparser),INTENT(inout) :: this
2497!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2498!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2499CHARACTER(len=*) :: help
2500
2501INTEGER :: i
2502TYPE(option) :: myoption
2503
2504! common initialisation
2505myoption = option_new('_', '_', '', help)
2506IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2507
2508myoption%opttype = opttype_sep
2509myoption%need_arg = 0
2510
2511i = arrayof_option_append(this%options, myoption)
2512
2513END SUBROUTINE optionparser_add_sep
2514
2515
2525SUBROUTINE optionparser_parse(this, nextarg, status)
2526TYPE(optionparser),INTENT(inout) :: this
2527INTEGER,INTENT(out) :: nextarg
2528INTEGER,INTENT(out) :: status
2529
2530INTEGER :: i, j, endopt, indeq, iargc
2531CHARACTER(len=16384) :: arg, optarg
2532
2533status = optionparser_ok
2534i = 1
2535DO WHILE(i <= iargc())
2536 CALL getarg(i, arg)
2537 IF (arg == '--') THEN ! explicit end of options
2538 i = i + 1 ! skip present option (--)
2539 EXIT
2540 ELSE IF (arg == '-') THEN ! a single - is not an option
2541 EXIT
2542 ELSE IF (arg(1:2) == '--') THEN ! long option
2543 indeq = index(arg, '=')
2544 IF (indeq /= 0) THEN ! = present
2545 endopt = indeq - 1
2546 ELSE ! no =
2547 endopt = len_trim(arg)
2548 ENDIF
2549 find_longopt: DO j = 1, this%options%arraysize
2550 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2551 SELECT CASE(this%options%array(j)%need_arg)
2552 CASE(2) ! compulsory
2553 IF (indeq /= 0) THEN
2554 optarg = arg(indeq+1:)
2555 status = max(option_found(this%options%array(j), optarg), &
2556 status)
2557 ELSE
2558 IF (i < iargc()) THEN
2559 i=i+1
2560 CALL getarg(i, optarg)
2561 status = max(option_found(this%options%array(j), optarg), &
2562 status)
2563 ELSE
2564 status = optionparser_err
2565 CALL l4f_log(l4f_error, &
2566 'in optionparser, option '''//trim(arg)//''' requires an argument')
2567 ENDIF
2568 ENDIF
2569 CASE(1) ! optional
2570 IF (indeq /= 0) THEN
2571 optarg = arg(indeq+1:)
2572 ELSE
2573 IF (i < iargc()) THEN
2574 CALL getarg(i+1, optarg)
2575 IF (optarg(1:1) == '-') THEN
2576 optarg = cmiss ! refused
2577 ELSE
2578 i=i+1 ! accepted
2579 ENDIF
2580 ELSE
2581 optarg = cmiss ! refused
2582 ENDIF
2583 ENDIF
2584 status = max(option_found(this%options%array(j), optarg), &
2585 status)
2586 CASE(0)
2587 status = max(option_found(this%options%array(j)), &
2588 status)
2589 END SELECT
2590 EXIT find_longopt
2591 ENDIF
2592 ENDDO find_longopt
2593 IF (j > this%options%arraysize) THEN
2594 status = optionparser_err
2595 CALL l4f_log(l4f_error, &
2596 'in optionparser, option '''//trim(arg)//''' not valid')
2597 ENDIF
2598 ELSE IF (arg(1:1) == '-') THEN ! short option
2599 find_shortopt: DO j = 1, this%options%arraysize
2600 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2601 SELECT CASE(this%options%array(j)%need_arg)
2602 CASE(2) ! compulsory
2603 IF (len_trim(arg) > 2) THEN
2604 optarg = arg(3:)
2605 status = max(option_found(this%options%array(j), optarg), &
2606 status)
2607 ELSE
2608 IF (i < iargc()) THEN
2609 i=i+1
2610 CALL getarg(i, optarg)
2611 status = max(option_found(this%options%array(j), optarg), &
2612 status)
2613 ELSE
2614 status = optionparser_err
2615 CALL l4f_log(l4f_error, &
2616 'in optionparser, option '''//trim(arg)//''' requires an argument')
2617 ENDIF
2618 ENDIF
2619 CASE(1) ! optional
2620 IF (len_trim(arg) > 2) THEN
2621 optarg = arg(3:)
2622 ELSE
2623 IF (i < iargc()) THEN
2624 CALL getarg(i+1, optarg)
2625 IF (optarg(1:1) == '-') THEN
2626 optarg = cmiss ! refused
2627 ELSE
2628 i=i+1 ! accepted
2629 ENDIF
2630 ELSE
2631 optarg = cmiss ! refused
2632 ENDIF
2633 ENDIF
2634 status = max(option_found(this%options%array(j), optarg), &
2635 status)
2636 CASE(0)
2637 status = max(option_found(this%options%array(j)), &
2638 status)
2639 END SELECT
2640 EXIT find_shortopt
2641 ENDIF
2642 ENDDO find_shortopt
2643 IF (j > this%options%arraysize) THEN
2644 status = optionparser_err
2645 CALL l4f_log(l4f_error, &
2646 'in optionparser, option '''//trim(arg)//''' not valid')
2647 ENDIF
2648 ELSE ! unrecognized = end of options
2649 EXIT
2650 ENDIF
2651 i = i + 1
2652ENDDO
2653
2654nextarg = i
2655SELECT CASE(status)
2656CASE(optionparser_err, optionparser_help)
2657 CALL optionparser_printhelp(this)
2658END SELECT
2659
2660END SUBROUTINE optionparser_parse
2661
2662
2666SUBROUTINE optionparser_printhelp(this)
2667TYPE(optionparser),INTENT(in) :: this
2668
2669INTEGER :: i, form
2670
2671form = 0
2672DO i = 1, this%options%arraysize ! loop over options
2673 IF (this%options%array(i)%opttype == opttype_help) THEN
2674 form = this%options%array(i)%helpformat
2675 ENDIF
2676ENDDO
2677
2678SELECT CASE(form)
2679CASE(0)
2680 CALL optionparser_printhelptxt(this)
2681CASE(1)
2682 CALL optionparser_printhelpmd(this)
2683CASE(2)
2684 CALL optionparser_printhelphtmlform(this)
2685END SELECT
2686
2687END SUBROUTINE optionparser_printhelp
2688
2689
2693SUBROUTINE optionparser_printhelptxt(this)
2694TYPE(optionparser),INTENT(in) :: this
2695
2696INTEGER :: i, j, ncols
2697CHARACTER(len=80) :: buf
2698TYPE(line_split) :: help_line
2699
2700ncols = default_columns()
2701
2702! print usage message
2703IF (ASSOCIATED(this%usage_msg)) THEN
2704 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2705 DO j = 1, line_split_get_nlines(help_line)
2706 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2707 ENDDO
2708 CALL delete(help_line)
2709ELSE
2710 CALL getarg(0, buf)
2711 i = index(buf, '/', back=.true.) ! remove directory part
2712 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2713 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2714ENDIF
2715
2716! print description message
2717IF (ASSOCIATED(this%description_msg)) THEN
2718 WRITE(*,'()')
2719 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2720 DO j = 1, line_split_get_nlines(help_line)
2721 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2722 ENDDO
2723 CALL delete(help_line)
2724ENDIF
2725
2726WRITE(*,'(/,A)')'Options:'
2727
2728DO i = 1, this%options%arraysize ! loop over options
2729 CALL option_format_help(this%options%array(i), ncols)
2730ENDDO
2731
2732END SUBROUTINE optionparser_printhelptxt
2733
2734
2738SUBROUTINE optionparser_printhelpmd(this)
2739TYPE(optionparser),INTENT(in) :: this
2740
2741INTEGER :: i, j, ncols
2742CHARACTER(len=80) :: buf
2743TYPE(line_split) :: help_line
2744
2745ncols = default_columns()
2746
2747! print usage message
2748WRITE(*,'(A)')'### Synopsis'
2749
2750IF (ASSOCIATED(this%usage_msg)) THEN
2751 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2752 DO j = 1, line_split_get_nlines(help_line)
2753 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2754 ENDDO
2755 CALL delete(help_line)
2756ELSE
2757 CALL getarg(0, buf)
2758 i = index(buf, '/', back=.true.) ! remove directory part
2759 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2760 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2761ENDIF
2762
2763! print description message
2764IF (ASSOCIATED(this%description_msg)) THEN
2765 WRITE(*,'()')
2766 WRITE(*,'(A)')'### Description'
2767 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2768 DO j = 1, line_split_get_nlines(help_line)
2769 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2770 ENDDO
2771 CALL delete(help_line)
2772
2773ENDIF
2774
2775WRITE(*,'(/,A)')'### Options'
2776
2777DO i = 1, this%options%arraysize ! loop over options
2778 CALL option_format_md(this%options%array(i), ncols)
2779ENDDO
2780
2781CONTAINS
2782
2783FUNCTION mdquote_usage_msg(usage_msg)
2784CHARACTER(len=*),INTENT(in) :: usage_msg
2785
2786CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2787INTEGER :: colon
2788
2789colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2790IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2791 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2792ELSE
2793 mdquote_usage_msg = usage_msg
2794ENDIF
2795
2796END FUNCTION mdquote_usage_msg
2797
2798END SUBROUTINE optionparser_printhelpmd
2799
2803SUBROUTINE optionparser_printhelphtmlform(this)
2804TYPE(optionparser),INTENT(in) :: this
2805
2806INTEGER :: i
2807
2808DO i = 1, this%options%arraysize ! loop over options
2809 CALL option_format_htmlform(this%options%array(i))
2810ENDDO
2811
2812WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2813
2814END SUBROUTINE optionparser_printhelphtmlform
2815
2816
2817SUBROUTINE optionparser_make_completion(this)
2818TYPE(optionparser),INTENT(in) :: this
2819
2820INTEGER :: i
2821CHARACTER(len=512) :: buf
2822
2823CALL getarg(0, buf)
2824
2825WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2826
2827WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2828 'case "$cur" in','-*)'
2829
2830!-*)
2831! COMPREPLY=( $( compgen -W
2832DO i = 1, this%options%arraysize ! loop over options
2833 IF (this%options%array(i)%need_arg == 2) THEN
2834 ENDIF
2835ENDDO
2836
2837WRITE(*,'(A/A/A)')'esac','return 0','}'
2838
2839END SUBROUTINE optionparser_make_completion
2840
2841
2842SUBROUTINE dirty_char_assignment(destc, destclen, src)
2843USE kinds
2844IMPLICIT NONE
2845
2846CHARACTER(len=1) :: destc(*)
2847CHARACTER(len=*) :: src
2848INTEGER :: destclen
2849
2850INTEGER :: i
2851
2852DO i = 1, min(destclen, len(src))
2853 destc(i) = src(i:i)
2854ENDDO
2855DO i = len(src)+1, destclen
2856 destc(i) = ' '
2857ENDDO
2858
2859END SUBROUTINE dirty_char_assignment
2860
2861END MODULE optionparser_class
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.
Methods for successively obtaining the fields of a csv_record object.
Constructor for the class csv_record.
Index method.
Destructor for the optionparser class.
Add a new option of a specific type.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition kinds.F90:245
classe per la gestione del logging
Module for parsing command-line optons.
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.